parent
d7741a3374
commit
fbf6a0af61
11 changed files with 550 additions and 0 deletions
@ -0,0 +1,30 @@ |
||||
Copyright Gaël Depreeuw (c) 2018 |
||||
|
||||
All rights reserved. |
||||
|
||||
Redistribution and use in source and binary forms, with or without |
||||
modification, are permitted provided that the following conditions are met: |
||||
|
||||
* Redistributions of source code must retain the above copyright |
||||
notice, this list of conditions and the following disclaimer. |
||||
|
||||
* Redistributions in binary form must reproduce the above |
||||
copyright notice, this list of conditions and the following |
||||
disclaimer in the documentation and/or other materials provided |
||||
with the distribution. |
||||
|
||||
* Neither the name of Gaël Depreeuw nor the names of other |
||||
contributors may be used to endorse or promote products derived |
||||
from this software without specific prior written permission. |
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS |
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT |
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR |
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT |
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, |
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT |
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, |
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY |
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT |
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE |
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
@ -0,0 +1,27 @@ |
||||
# fingerd |
||||
|
||||
## Excercise 1 |
||||
|
||||
Add new user: |
||||
|
||||
```shell |
||||
sudo sqlite3 finger.db |
||||
> insert into users values(Null, 'foo', '/bin/sh', '/home/foo', 'Foo Bar', '1234'); |
||||
> select * from users; |
||||
1|gdp|/bin/sh|/home/gdp|Gaël Depreeuw|555-123-4567 |
||||
2|foo|/bin/sh|/home/foo|Foo Bar|1234 |
||||
``` |
||||
|
||||
Update existing user: |
||||
|
||||
```shell |
||||
sudo sqlite3 finger.db |
||||
> update users set phone='n/a' where id=1 |
||||
> select * from users; |
||||
1|gdp|/bin/sh|/home/gdp|Gaël Depreeuw|n/a |
||||
2|foo|/bin/sh|/home/foo|Foo Bar|1234 |
||||
``` |
||||
|
||||
## Excercise 2 |
||||
|
||||
see [src/AddUser.hs](./src/AddUser.hs) |
@ -0,0 +1,2 @@ |
||||
import Distribution.Simple |
||||
main = defaultMain |
Binary file not shown.
@ -0,0 +1,69 @@ |
||||
name: fingerd |
||||
version: 0.1.0.0 |
||||
synopsis: Simple project template |
||||
description: Please see README.md |
||||
homepage: https://github.com/Mithror/fingerd#readme |
||||
license: BSD3 |
||||
license-file: LICENSE |
||||
author: Gaël Depreeuw |
||||
maintainer: gael.depreeuw@gmail.com |
||||
copyright: Copyright (c) 2018 Gaël Depreeuw |
||||
category: daemon |
||||
build-type: Simple |
||||
cabal-version: >=1.10 |
||||
extra-source-files: README.md |
||||
|
||||
library |
||||
hs-source-dirs: lib |
||||
exposed-modules: UserDB |
||||
default-language: Haskell2010 |
||||
build-depends: base >= 4.7 && < 5 |
||||
, bytestring |
||||
, network |
||||
, raw-strings-qq |
||||
, sqlite-simple |
||||
, text |
||||
, aeson |
||||
|
||||
-- library userdb-internal |
||||
-- hs-source-dirs: lib |
||||
-- exposed-modules: UserDB.Internal |
||||
-- default-language: Haskell2010 |
||||
-- build-depends: base >= 4.7 && < 5 |
||||
-- , bytestring |
||||
-- , network |
||||
-- , raw-strings-qq |
||||
-- , sqlite-simple |
||||
-- , text |
||||
|
||||
executable debug |
||||
ghc-options: -Wall |
||||
hs-source-dirs: src |
||||
main-is: Debug.hs |
||||
default-language: Haskell2010 |
||||
build-depends: base >= 4.7 && < 5 |
||||
, network |
||||
|
||||
executable adduser |
||||
ghc-options: -Wall |
||||
hs-source-dirs: src |
||||
main-is: AddUser.hs |
||||
default-language: Haskell2010 |
||||
build-depends: base >= 4.7 && < 5 |
||||
, sqlite-simple |
||||
, text |
||||
, fingerd |
||||
|
||||
executable fingerd |
||||
ghc-options: -Wall |
||||
hs-source-dirs: src |
||||
main-is: Main.hs |
||||
default-language: Haskell2010 |
||||
build-depends: base >= 4.7 && < 5 |
||||
, bytestring |
||||
, network |
||||
, raw-strings-qq |
||||
, sqlite-simple |
||||
, text |
||||
, fingerd |
||||
, aeson |
@ -0,0 +1,147 @@ |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
-- {-# LANGUAGE QuasiQuotes #-} |
||||
|
||||
module UserDB |
||||
( User(..), getSingleUser, getAllUsers, addUser, updateUser) |
||||
where |
||||
|
||||
import Control.Exception |
||||
import Data.Text (Text) |
||||
-- import Data.Text.Encoding (decodeUtf8, encodeUtf8) |
||||
import Database.SQLite.Simple hiding (close) |
||||
import Database.SQLite.Simple as SQLite |
||||
-- import Database.SQLite.Simple.Types |
||||
import Data.Typeable |
||||
-- import Text.RawString.QQ |
||||
import Data.Maybe (catMaybes) |
||||
import Data.List (intersperse) |
||||
import Data.String (fromString) |
||||
import Data.Aeson |
||||
|
||||
data User = |
||||
User { |
||||
userId :: Integer |
||||
, username :: Text |
||||
, shell :: Text |
||||
, homeDirectory :: Text |
||||
, realName :: Text |
||||
, phone :: Text |
||||
} deriving (Eq, Show) |
||||
|
||||
instance FromRow User where |
||||
fromRow = User <$> field |
||||
<*> field |
||||
<*> field |
||||
<*> field |
||||
<*> field |
||||
<*> field |
||||
|
||||
instance ToRow User where |
||||
toRow (User id_ uname sh hDir rName ph) = |
||||
toRow (id_, uname, sh, hDir, rName, ph) |
||||
|
||||
instance FromJSON User where |
||||
parseJSON = withObject "User" $ \v -> User 0 |
||||
<$> v .: "username" |
||||
<*> v .: "shell" |
||||
<*> v .: "homeDirectory" |
||||
<*> v .: "realName" |
||||
<*> v .: "phone" |
||||
|
||||
-- createUsers :: Query |
||||
-- createUsers = [r| |
||||
-- CREATE TABLE IF NOT EXISTS users |
||||
-- (id INTEGER PRIMARY KEY AUTOINCREMENT, |
||||
-- username TEXT UNIQUE, |
||||
-- shell TEXT, homeDirectory TEXT, |
||||
-- realName TEXT, phone TEXT) |
||||
-- |] |
||||
|
||||
insertUser :: Query |
||||
insertUser = "INSERT INTO users VALUES (?, ?, ?, ?, ?, ?)" |
||||
|
||||
allUsers :: Query |
||||
allUsers = "SELECT * from users" |
||||
|
||||
getUserQuery :: Query |
||||
getUserQuery = "SELECT * from users where username = ?" |
||||
|
||||
data DuplicateData = DuplicateData deriving (Eq, Show, Typeable) |
||||
|
||||
instance Exception DuplicateData |
||||
|
||||
-- type UserRow = (Null, Text, Text, Text, Text, Text) |
||||
|
||||
getUser :: Connection -> Text -> IO (Maybe User) |
||||
getUser conn uname = do |
||||
results <- query conn getUserQuery (Only uname) |
||||
case results of |
||||
[] -> return $ Nothing |
||||
[user] -> return $ Just user |
||||
_ -> throwIO DuplicateData |
||||
|
||||
addUser :: User -> IO Bool |
||||
addUser u = do |
||||
conn <- getConnection |
||||
n <- query conn hasUser (Only $ username u) :: IO [Only Integer] |
||||
b <- case n of |
||||
[] -> (execute conn insertUser $ toRow u) >> return True |
||||
_ -> return False |
||||
rows <- query_ conn allUsers |
||||
mapM_ print (rows :: [User]) |
||||
SQLite.close conn |
||||
return b |
||||
|
||||
-- createDatabase :: IO () |
||||
-- createDatabase = do |
||||
-- conn <- getConnection |
||||
-- execute_ conn createUsers |
||||
-- SQLite.close conn |
||||
|
||||
getConnection :: IO Connection |
||||
getConnection = open "finger.db" |
||||
|
||||
getSingleUser :: Text -> IO (Maybe User) |
||||
getSingleUser name = do |
||||
conn <- getConnection |
||||
result <- getUser conn name |
||||
SQLite.close conn |
||||
return result |
||||
|
||||
getAllUsers :: IO [User] |
||||
getAllUsers = do |
||||
conn <- getConnection |
||||
rows <- query_ conn allUsers |
||||
SQLite.close conn |
||||
return rows |
||||
|
||||
hasUser :: Query |
||||
hasUser = "SELECT 1 FROM users where username = ?" |
||||
|
||||
updateUser :: String |
||||
-> Maybe String |
||||
-> Maybe String |
||||
-> Maybe String |
||||
-> Maybe String |
||||
-> IO Bool |
||||
updateUser name sh hDir rName ph = do |
||||
let xs = [sh, hDir, rName, ph] |
||||
columns = zip ["shell", "homeDirectory", "realName", "phone"] xs |
||||
newData = catMaybes $ fmap sequenceA columns |
||||
case newData of |
||||
[] -> return True |
||||
ys -> do |
||||
let pairs = fmap (\(a,b) -> a ++ "=\"" ++ b ++ "\"" ) ys |
||||
part = concat $ intersperse "," pairs |
||||
full = "update users set " ++ part |
||||
++ " where username = \"" ++ name ++ "\"" |
||||
conn <- getConnection |
||||
n <- query conn hasUser (Only name) :: IO [Only Integer] |
||||
b <- case n of |
||||
[] -> return False |
||||
_ -> execute conn (fromString full) (Only name) >> return True |
||||
SQLite.close conn |
||||
return b |
||||
|
||||
-- updateU :: User -> IO () |
||||
-- update |
@ -0,0 +1,45 @@ |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Main where |
||||
|
||||
import UserDB |
||||
|
||||
import Data.Text (Text) |
||||
import qualified Data.Text as T |
||||
import System.Environment (getArgs) |
||||
import System.IO (hSetBuffering, BufferMode(..), stdout) |
||||
import Data.String (fromString) |
||||
|
||||
addUser' :: Text -> IO () |
||||
addUser' name = do |
||||
s <- fmap fromString $ putStr "Shell: " >> getLine |
||||
h <- fmap fromString $ putStr "Home Dir: " >> getLine |
||||
r <- fmap fromString $ putStr "Real name: " >> getLine |
||||
p <- fmap fromString $ putStr "Phone no.: " >> getLine |
||||
b <- addUser $ User 0 name s h r p |
||||
case b of |
||||
True -> putStrLn "User succesfully added." |
||||
False -> putStrLn "User already exists" |
||||
|
||||
updateUser' :: Text -> IO () |
||||
updateUser' name = do |
||||
let f "" = Nothing |
||||
f a = Just a |
||||
putStrLn "Use blank if you don't want to update." |
||||
s <- fmap f $ putStr "Shell: " >> getLine |
||||
h <- fmap f $ putStr "Home Dir: " >> getLine |
||||
r <- fmap f $ putStr "Real name: " >> getLine |
||||
p <- fmap f $ putStr "Phone no.: " >> getLine |
||||
b <- updateUser (T.unpack name) s h r p |
||||
case b of |
||||
True -> putStrLn "User succesfully updated." |
||||
False -> putStrLn "No such user found." |
||||
|
||||
main :: IO () |
||||
main = do |
||||
hSetBuffering stdout NoBuffering |
||||
args <- getArgs |
||||
case args of |
||||
["add", name] -> addUser' $ T.pack name |
||||
["update", name] -> updateUser' $ T.pack name |
||||
_ -> putStrLn "add <name> | update <name>" |
@ -0,0 +1,29 @@ |
||||
module Main where |
||||
|
||||
import Control.Monad (forever) |
||||
import Network.Socket hiding (recv) |
||||
import Network.Socket.ByteString (recv, sendAll) |
||||
|
||||
logAndEcho :: Socket -> IO () |
||||
logAndEcho sock = forever $ do |
||||
(soc, _) <- accept sock |
||||
printAndKickback soc |
||||
sClose soc |
||||
where printAndKickback conn = do |
||||
msg <- recv conn 1024 |
||||
print msg |
||||
sendAll conn msg |
||||
|
||||
|
||||
main :: IO () |
||||
main = withSocketsDo $ do |
||||
addrinfos <- getAddrInfo |
||||
(Just (defaultHints {addrFlags = [AI_PASSIVE]})) |
||||
Nothing |
||||
(Just "79") |
||||
let serveraddr = head addrinfos |
||||
sock <- socket (addrFamily serveraddr) Stream defaultProtocol |
||||
bindSocket sock (addrAddress serveraddr) |
||||
listen sock 1 |
||||
logAndEcho sock |
||||
sClose sock |
@ -0,0 +1,136 @@ |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Main where |
||||
|
||||
import UserDB (User(..), getAllUsers, getSingleUser, addUser) |
||||
|
||||
import Control.Concurrent |
||||
-- import Control.Concurrent.MVar |
||||
import Control.Monad (forever) |
||||
import Data.List (intersperse) |
||||
import Data.Text (Text) |
||||
import qualified Data.Text as T |
||||
import Data.ByteString (ByteString) |
||||
import qualified Data.ByteString as BS |
||||
import qualified Data.ByteString.Lazy as BSL |
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8) |
||||
import Network.Socket hiding ({-close,-} recv) |
||||
import Network.Socket.ByteString (recv, sendAll) |
||||
import Data.Aeson |
||||
|
||||
getAllUsers' :: MVar Bool -> IO [User] |
||||
getAllUsers' m = do |
||||
m' <- takeMVar m |
||||
users <- getAllUsers |
||||
putMVar m m' |
||||
return users |
||||
|
||||
addUser' :: MVar Bool -> User -> IO () |
||||
addUser' m u = do |
||||
m' <- takeMVar m |
||||
b <- addUser u |
||||
print b |
||||
putMVar m m' |
||||
|
||||
formatUser :: User -> ByteString |
||||
formatUser (User _ uname sh homeDir rName _) = BS.concat |
||||
[ "Login: ", e uname, "\t\t\t\t" |
||||
, "Name: ", e rName, "\n" |
||||
, "Directory: ", e homeDir, "\t\t\t" |
||||
, "Shell: ", e sh, "\n"] |
||||
where e = encodeUtf8 |
||||
|
||||
returnUsers :: Socket -> MVar Bool -> IO () |
||||
returnUsers soc m = do |
||||
rows <- getAllUsers-- m |
||||
let usernames = map username rows |
||||
newlineSeparated = T.concat $ intersperse "\n" usernames |
||||
sendAll soc (encodeUtf8 newlineSeparated) |
||||
|
||||
returnUser :: Socket -> Text -> IO () |
||||
returnUser soc uname = do |
||||
maybeUser <- getSingleUser uname |
||||
case maybeUser of |
||||
Nothing -> do |
||||
putStrLn $ "Couldn't find matching user for username: " ++ show uname |
||||
return () |
||||
Just user -> sendAll soc (formatUser user) |
||||
|
||||
handleQuery :: Socket -> MVar Bool -> IO () |
||||
handleQuery soc m = do |
||||
msg <- recv soc 1024 |
||||
case msg of |
||||
"\r\n" -> returnUsers soc m |
||||
name -> returnUser soc (decodeUtf8 name) |
||||
|
||||
handleQueries :: Socket -> MVar Bool -> IO () |
||||
handleQueries sock m = forever $ do |
||||
(soc, _) <- accept sock |
||||
putStrLn "Got connection, handling query" |
||||
handleQuery soc m |
||||
Network.Socket.close soc -- sClose soc is deprecated |
||||
|
||||
fingerd :: MVar Bool -> IO () |
||||
fingerd m = do |
||||
withSocketsDo $ do |
||||
addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) |
||||
Nothing |
||||
(Just "79") |
||||
let serveraddr = head addrinfos |
||||
sock <- socket (addrFamily serveraddr) Stream defaultProtocol |
||||
Network.Socket.bind sock (addrAddress serveraddr) |
||||
-- bindSocket sock (addrAddress serveraddr) is deprecated |
||||
listen sock 1 |
||||
-- only one connection open at a time |
||||
handleQueries sock m |
||||
Network.Socket.close sock -- sClose sock is deprecated |
||||
|
||||
recvJson :: Socket -> IO ByteString |
||||
recvJson soc = do |
||||
msg <- recv soc 1024 |
||||
let l = BS.length msg |
||||
case l of |
||||
0 -> do |
||||
msg' <- recvJson soc |
||||
return $ msg `BS.append` msg' |
||||
_ -> case BS.last msg of |
||||
0 -> return $ BS.take (l - 1) msg |
||||
_ -> do |
||||
msg' <- recvJson soc |
||||
return $ msg `BS.append` msg' |
||||
-- return msg |
||||
|
||||
handleRequest :: Socket -> MVar Bool -> IO () |
||||
handleRequest sock m = forever $ do |
||||
(soc, _) <- accept sock |
||||
putStrLn "Woohoo!" |
||||
j <- recvJson soc |
||||
print j |
||||
case decode (BSL.fromStrict j) of |
||||
Nothing -> putStrLn "Cannot decode." |
||||
(Just u) -> do |
||||
putStrLn $ "Decoded User: " ++ show u |
||||
addUser' m u |
||||
Network.Socket.close soc -- sClose soc is deprecated |
||||
|
||||
add :: MVar Bool -> IO () |
||||
add m = do |
||||
withSocketsDo $ do |
||||
addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) |
||||
Nothing |
||||
(Just "4242") |
||||
let serveraddr = head addrinfos |
||||
sock <- socket (addrFamily serveraddr) Stream defaultProtocol |
||||
Network.Socket.bind sock (addrAddress serveraddr) |
||||
-- bindSocket sock (addrAddress serveraddr) is deprecated |
||||
listen sock 1 |
||||
-- only one connection open at a time |
||||
handleRequest sock m |
||||
Network.Socket.close sock -- sClose sock is deprecated |
||||
|
||||
main :: IO () |
||||
-- main = createDatabase |
||||
main = do |
||||
m <- newMVar True |
||||
_ <- forkIO $ add m |
||||
fingerd m |
@ -0,0 +1,65 @@ |
||||
# This file was automatically generated by 'stack init' |
||||
# |
||||
# Some commonly used options have been documented as comments in this file. |
||||
# For advanced use and comprehensive documentation of the format, please see: |
||||
# https://docs.haskellstack.org/en/stable/yaml_configuration/ |
||||
|
||||
# Resolver to choose a 'specific' stackage snapshot or a compiler version. |
||||
# A snapshot resolver dictates the compiler version and the set of packages |
||||
# to be used for project dependencies. For example: |
||||
# |
||||
# resolver: lts-3.5 |
||||
# resolver: nightly-2015-09-21 |
||||
# resolver: ghc-7.10.2 |
||||
# resolver: ghcjs-0.1.0_ghc-7.10.2 |
||||
# |
||||
# The location of a snapshot can be provided as a file or url. Stack assumes |
||||
# a snapshot provided as a file might change, whereas a url resource does not. |
||||
# |
||||
# resolver: ./custom-snapshot.yaml |
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml |
||||
resolver: lts-11.13 |
||||
|
||||
# User packages to be built. |
||||
# Various formats can be used as shown in the example below. |
||||
# |
||||
# packages: |
||||
# - some-directory |
||||
# - https://example.com/foo/bar/baz-0.0.2.tar.gz |
||||
# - location: |
||||
# git: https://github.com/commercialhaskell/stack.git |
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a |
||||
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a |
||||
# subdirs: |
||||
# - auto-update |
||||
# - wai |
||||
packages: |
||||
- . |
||||
# Dependency packages to be pulled from upstream that are not in the resolver |
||||
# using the same syntax as the packages field. |
||||
# (e.g., acme-missiles-0.3) |
||||
# extra-deps: [] |
||||
|
||||
# Override default flag values for local packages and extra-deps |
||||
# flags: {} |
||||
|
||||
# Extra package databases containing global packages |
||||
# extra-package-dbs: [] |
||||
|
||||
# Control whether we use the GHC we find on the path |
||||
# system-ghc: true |
||||
# |
||||
# Require a specific version of stack, using version ranges |
||||
# require-stack-version: -any # Default |
||||
# require-stack-version: ">=1.7" |
||||
# |
||||
# Override the architecture used by stack, especially useful on Windows |
||||
# arch: i386 |
||||
# arch: x86_64 |
||||
# |
||||
# Extra directories used by stack for building |
||||
# extra-include-dirs: [/path/to/dir] |
||||
# extra-lib-dirs: [/path/to/dir] |
||||
# |
||||
# Allow a newer minor version of GHC than the snapshot specifies |
||||
# compiler-check: newer-minor |
Binary file not shown.
Loading…
Reference in new issue