Complete chapter 31

31-final-project/fingerd/LICENSE

@@ -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.

31-final-project/fingerd/README.md

@@ -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)

31-final-project/fingerd/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

31-final-project/fingerd/fingerd.cabal

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

31-final-project/fingerd/lib/UserDB.hs

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

31-final-project/fingerd/src/AddUser.hs

@@ -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>"

31-final-project/fingerd/src/Debug.hs

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

31-final-project/fingerd/src/Main.hs

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

31-final-project/fingerd/stack.yaml

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