Improve finger daemon

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
+  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

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

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,10 +145,10 @@ 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
@@ -142,6 +156,3 @@ updateUser name sh hDir rName ph = do
                 _ ->  execute conn (fromString full) (Only name) >> return True
             SQLite.close conn
             return b
-
--- updateU :: User -> IO ()
--- update