diff --git a/31-final-project/fingerd/finger.db b/31-final-project/fingerd/finger.db index 03aa280..33831a0 100644 Binary files a/31-final-project/fingerd/finger.db and b/31-final-project/fingerd/finger.db differ diff --git a/31-final-project/fingerd/fingerd.cabal b/31-final-project/fingerd/fingerd.cabal index 4198b4e..9162bd2 100644 --- a/31-final-project/fingerd/fingerd.cabal +++ b/31-final-project/fingerd/fingerd.cabal @@ -13,21 +13,9 @@ 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 +-- library -- hs-source-dirs: lib --- exposed-modules: UserDB.Internal +-- exposed-modules: UserDB -- default-language: Haskell2010 -- build-depends: base >= 4.7 && < 5 -- , bytestring @@ -35,6 +23,7 @@ library -- , raw-strings-qq -- , sqlite-simple -- , text +-- , aeson executable debug ghc-options: -Wall @@ -44,26 +33,31 @@ executable debug build-depends: base >= 4.7 && < 5 , network -executable adduser +executable db-tool ghc-options: -Wall hs-source-dirs: src - main-is: AddUser.hs + main-is: DBTool.hs default-language: Haskell2010 + other-modules: UserDB build-depends: base >= 4.7 && < 5 , sqlite-simple , text - , fingerd + , aeson + , raw-strings-qq 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 \ No newline at end of file + ghc-options: -Wall + other-modules: UserDB + hs-source-dirs: src + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , bytestring + , network + , sqlite-simple + , text + , aeson + , raw-strings-qq + , containers + , unordered-containers + , vector \ No newline at end of file diff --git a/31-final-project/fingerd/src/AddUser.hs b/31-final-project/fingerd/src/DBTool.hs similarity index 100% rename from 31-final-project/fingerd/src/AddUser.hs rename to 31-final-project/fingerd/src/DBTool.hs diff --git a/31-final-project/fingerd/src/Main.hs b/31-final-project/fingerd/src/Main.hs index 7c92c8e..874f863 100644 --- a/31-final-project/fingerd/src/Main.hs +++ b/31-final-project/fingerd/src/Main.hs @@ -2,35 +2,142 @@ module Main where -import UserDB (User(..), getAllUsers, getSingleUser, addUser) +import UserDB (User(..), getAllUsers, getSingleUser, addUser, + updateUser, deleteUser) import Control.Concurrent --- import Control.Concurrent.MVar import Control.Monad (forever) -import Data.List (intersperse) +import Data.List (intersperse, intercalate) 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 hiding (recv) import Network.Socket.ByteString (recv, sendAll) import Data.Aeson +import Control.Applicative (empty) +import qualified Data.HashMap.Lazy as HML -getAllUsers' :: MVar Bool -> IO [User] -getAllUsers' m = do - m' <- takeMVar m - users <- getAllUsers - putMVar m m' - return users +import Data.Aeson.Types +import Data.Either (lefts) +import Data.String (fromString) -addUser' :: MVar Bool -> User -> IO () -addUser' m u = do - m' <- takeMVar m - b <- addUser u - print b - putMVar m m' +-- type UserName = Text + +-- { +-- "actions" : [ +-- { +-- "action" : "delete", +-- "params" : "gdp" +-- }, +-- { +-- "action" : "add", +-- "params" : { +-- "username" : "gdp", +-- "shell" : "/bin/sh", +-- "homeDirectory" : "/home/gdp", +-- "realName" : "Gaël Depreeuw", +-- "phone" : "555-123-456789" +-- } +-- }, +-- { +-- "action" : "update", +-- "params" : { +-- "username" : "gdp", +-- "newUsername" : "...", +-- "newShell" : "...", +-- "newHomedirectory" : "...", +-- "newRealName" : "...", +-- "newPhone" : "...", +-- } +-- } +-- ] +-- } + +data UserUpdate = UserUpdate { + name :: String, + mbUsername :: Maybe String, + mbShell :: Maybe String, + mbHomeDirectory :: Maybe String, + mbRealName :: Maybe String, + mbPhone :: Maybe String +} deriving (Show, Eq) +instance FromJSON UserUpdate where + parseJSON = withObject "UserUpdate" $ \o -> UserUpdate + <$> o .: "username" + <*> o .:? "newUsername" + <*> o .:? "shell" + <*> o .:? "homeDirectory" + <*> o .:? "realName" + <*> o .:? "phone" + +data Action = DeleteAction Text + | AddUser User + | ModifyUser UserUpdate + deriving (Show, Eq) + +instance FromJSON Action where + parseJSON = withObject "Action" $ \o -> do + a <- o .: "action" :: Parser Text + let mbValue = HML.lookup "params" o + case mbValue of + Nothing -> empty + Just v -> case a of + "delete" -> DeleteAction <$> o .: "params" + "add" -> AddUser <$> parseJSON v + "update" -> ModifyUser <$> parseJSON v + _ -> empty + +data Config = Config [Action] deriving (Show, Eq) +instance FromJSON Config where + parseJSON = withObject "Config" $ \o -> Config <$> o .: "actions" + +-- instance FromJSON Config where +-- parseJSON = withObject "Config" $ \o -> +-- case HML.lookup "actions" o of +-- (Just (Array v)) -> Config <$> (mapM parseJSON $ V.toList v) +-- _ -> empty + +-- (.:) :: FromJSON a => Object -> Text -> Parser a +-- parseJSON :: FromJSON a => Value -> Parser a +-- withObject :: String -> (Object -> Parser a) -> Value -> Parser a +-- withArray :: String -> (Array -> Parser a) -> Value -> Parser a + +doAction :: MVar () -> Action -> IO (Either String ()) +doAction m (DeleteAction t) = do + b <- protect m $ deleteUser t + case b of + True -> return $ Right () + False -> return $ Left ("User " ++ (T.unpack t) + ++ " does not exist.") +doAction m (AddUser u) = do + b <- protect m $ addUser u + case b of + True -> return $ Right () + False -> return $ Left ("User " ++ (T.unpack $ username u) + ++ " exists already.") +doAction m (ModifyUser (UserUpdate n _ s h r p)) = do + b <- protect m $ updateUser n s h r p + case b of + True -> return $ Right () + False -> return $ Left ("User " ++ n + ++ " does not exist.") + +doConfig :: MVar () -> Config -> IO (Either String ()) +doConfig m (Config xs) = + f . lefts <$> mapM (doAction m) xs + where f [] = Right () + f ys = Left $ intercalate "\n" ys + +-- creates a critical section of the IO action +protect :: MVar () -> IO a -> IO a +protect m act = do + takeMVar m + a <- act + putMVar m () + return a formatUser :: User -> ByteString formatUser (User _ uname sh homeDir rName _) = BS.concat @@ -40,37 +147,53 @@ formatUser (User _ uname sh homeDir rName _) = BS.concat , "Shell: ", e sh, "\n"] where e = encodeUtf8 -returnUsers :: Socket -> MVar Bool -> IO () +returnUsers :: Socket -> MVar () -> IO () returnUsers soc m = do - rows <- getAllUsers-- m + rows <- protect m getAllUsers let usernames = map username rows - newlineSeparated = T.concat $ intersperse "\n" usernames - sendAll soc (encodeUtf8 newlineSeparated) + newlineSeparated = T.concat $ (intersperse "\n" usernames) + sendAll soc (encodeUtf8 $ T.append newlineSeparated "\n") -returnUser :: Socket -> Text -> IO () -returnUser soc uname = do - maybeUser <- getSingleUser uname +returnUser :: Socket -> MVar () -> Text -> IO () +returnUser soc m uname = do + maybeUser <- protect m $ 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 () +-- Modified this to accept message longer than 1024 +-- keeping in mind that \r\n might be split over two packages +recvCommand :: Socket -> IO (Maybe ByteString) +recvCommand soc = getData >>= checkForCRLF + where + getData = recv soc 1024 + checkForCRLF b = + if BS.isInfixOf "\r\n" b + then return . Just . BS.init . head . BS.split 0x0A $ b + else getData >>= stopOrContinue b + stopOrContinue b msg = + if BS.null b + then return Nothing + else checkForCRLF $ BS.append b msg + +handleQuery :: Socket -> MVar () -> IO () handleQuery soc m = do - msg <- recv soc 1024 + msg <- recvCommand soc case msg of - "\r\n" -> returnUsers soc m - name -> returnUser soc (decodeUtf8 name) + Nothing -> putStrLn "Client closed socket." + Just "" -> returnUsers soc m + Just n -> returnUser soc m (decodeUtf8 n) -handleQueries :: Socket -> MVar Bool -> IO () +handleQueries :: Socket -> MVar () -> 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 + close soc -fingerd :: MVar Bool -> IO () +fingerd :: MVar () -> IO () fingerd m = do withSocketsDo $ do addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) @@ -78,42 +201,32 @@ fingerd m = do (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 + bind sock (addrAddress serveraddr) -- only one connection open at a time + listen sock 1 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 () + close sock + +recvJson :: Socket -> IO (Maybe ByteString) +recvJson soc = recv soc 1024 >>= stopOrContinue + where stopOrContinue b + | BS.null b = return Nothing + | BS.last b == 0 = (return . Just $ BS.init b) + | otherwise = (fmap . fmap) (BS.append b) (recvJson soc) + +handleRequest :: Socket -> MVar () -> 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 () + resp <- case j >>= (decode . BSL.fromStrict) of + Nothing -> return "Cannot decode json.\r\n" + (Just c) -> createMsg <$> doConfig m c + sendAll soc resp + close soc + where createMsg (Right _) = "Actions succesfully applied.\r\n" + createMsg (Left s) = fromString s + +add :: MVar () -> IO () add m = do withSocketsDo $ do addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) @@ -121,16 +234,13 @@ add m = do (Just "4242") let serveraddr = head addrinfos sock <- socket (addrFamily serveraddr) Stream defaultProtocol - Network.Socket.bind sock (addrAddress serveraddr) - -- bindSocket sock (addrAddress serveraddr) is deprecated + bind sock (addrAddress serveraddr) listen sock 1 - -- only one connection open at a time handleRequest sock m - Network.Socket.close sock -- sClose sock is deprecated + close sock main :: IO () --- main = createDatabase main = do - m <- newMVar True + m <- newMVar () _ <- forkIO $ add m fingerd m \ No newline at end of file diff --git a/31-final-project/fingerd/lib/UserDB.hs b/31-final-project/fingerd/src/UserDB.hs similarity index 71% rename from 31-final-project/fingerd/lib/UserDB.hs rename to 31-final-project/fingerd/src/UserDB.hs index bf46b03..97f2e08 100644 --- a/31-final-project/fingerd/lib/UserDB.hs +++ b/31-final-project/fingerd/src/UserDB.hs @@ -1,21 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} --- {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes #-} module UserDB - ( User(..), getSingleUser, getAllUsers, addUser, updateUser) + ( User(..), getSingleUser, getAllUsers, addUser, updateUser, + deleteUser, createDatabase) 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 Text.RawString.QQ import Data.Aeson data User = @@ -48,17 +47,22 @@ instance FromJSON User where <*> 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) --- |] +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 (?, ?, ?, ?, ?, ?)" +insertUser = "INSERT INTO users\ + \ (username, shell, homeDirectory, realName, phone) \ + \ VALUES (?, ?, ?, ?, ?)" + +removeUser :: Query +removeUser = "DELETE from users where username = ?" allUsers :: Query allUsers = "SELECT * from users" @@ -85,18 +89,28 @@ 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 + [] -> (execute conn insertUser $ (tail $ 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 +deleteUser :: Text -> IO Bool +deleteUser u = do + conn <- getConnection + n <- query conn hasUser (Only u) :: IO [Only Integer] + b <- case n of + [] -> return False + _ -> (execute conn removeUser $ (Only u)) >> return True + SQLite.close conn + return b + +createDatabase :: IO () +createDatabase = do + conn <- getConnection + execute_ conn createUsers + SQLite.close conn getConnection :: IO Connection getConnection = open "finger.db" @@ -131,17 +145,14 @@ updateUser name sh hDir rName ph = do case newData of [] -> return True ys -> do - let pairs = fmap (\(a,b) -> a ++ "=\"" ++ b ++ "\"" ) ys - part = concat $ intersperse "," pairs + let pairs' = fmap (\(a,b) -> a ++ "=\"" ++ b ++ "\"" ) ys + part = concat $ intersperse "," pairs' full = "update users set " ++ part - ++ " where username = \"" ++ name ++ "\"" + ++ " where username = ?" 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 \ No newline at end of file + return b \ No newline at end of file diff --git a/31-final-project/fingerd/user.json b/31-final-project/fingerd/user.json index 5d58d2e..684b6bd 100644 Binary files a/31-final-project/fingerd/user.json and b/31-final-project/fingerd/user.json differ