Browse Source

init socket garbage

canon
Hazel Levine 2 years ago
parent
commit
c9453512b5
Signed by: hazel
GPG Key ID: 1884029A28789A62
  1. 30
      exe/Client.hs
  2. 21
      exe/Main.hs
  3. 6
      hsfingerd.cabal
  4. 11
      hsfingerd.nix
  5. 1
      result
  6. 21
      src/Hsfingerd/Database.hs
  7. 50
      src/Hsfingerd/Finger.hs
  8. 86
      src/Hsfingerd/User.hs

30
exe/Client.hs

@ -1,8 +1,13 @@
module Main where
import Database.SQLite.Simple
import Data.Aeson (encode)
import qualified Data.ByteString.Lazy as BSL
import Database.SQLite.Simple hiding (bind, close)
import qualified Database.SQLite.Simple as SQL
import Hsfingerd.Database
import Hsfingerd.User
import Network.Socket
import Network.Socket.ByteString (sendAll)
import Options.Applicative
data Command
@ -31,9 +36,24 @@ parseSubcommands =
runCommand :: Command -> Connection -> IO ()
runCommand Init conn = createDatabase conn
runCommand (Add row) conn = addUser conn row
-- XXX: simple-sqlite3 will not take it if it has the superfluous ":id"
runCommand (Update row) conn = updateUser conn (tail row)
--runCommand (Add row) conn = addUser conn row
runCommand (Update row) conn = updateUser conn row
runCommand (Add row) _ = withSocketsDo $ do
addrinfos <-
getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) Nothing (Just "80")
let clientaddr = head addrinfos
sock <- socket (addrFamily clientaddr) Stream defaultProtocol
connect sock (addrAddress clientaddr)
case toUserSerializable row of
Just us -> do
print us
print $ encode us
sendAll sock $ BSL.toStrict $ encode us
Nothing -> putStrLn "Invalid row specification"
close sock
main :: IO ()
main = do
@ -42,7 +62,7 @@ main = do
runCommand options conn
close conn
SQL.close conn
where
opts =
info

21
exe/Main.hs

@ -1,14 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Main where
import Control.Concurrent
import Database.SQLite.Simple hiding (bind, close)
import qualified Database.SQLite.Simple as SQL
import Hsfingerd.Finger
import Network.Socket
forkIO' :: IO () -> IO (MVar ())
forkIO' action = do
@ -17,13 +10,7 @@ forkIO' action = do
return done
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
bind sock (addrAddress serveraddr)
listen sock 1
conn <- open "finger.db"
handleQueries conn sock
SQL.close conn
close sock
main = do
queryThd <- forkIO' $ runHandler handleQueries "79"
modifyThd <- forkIO' $ runHandler handleModifications "80"
mapM_ takeMVar [queryThd, modifyThd]

6
hsfingerd.cabal

@ -26,7 +26,9 @@ library
raw-strings-qq,
sqlite-simple,
text,
transformers
transformers,
aeson,
containers
executable debug
ghc-options: -Wall
@ -55,4 +57,6 @@ executable hsfingerc
network,
sqlite-simple,
optparse-applicative,
aeson,
bytestring,
hsfingerd

11
hsfingerd.nix

@ -1,5 +1,6 @@
{ mkDerivation, base, bytestring, network, optparse-applicative
, raw-strings-qq, sqlite-simple, stdenv, text, transformers
{ mkDerivation, aeson, base, bytestring, containers, network
, optparse-applicative, raw-strings-qq, sqlite-simple, stdenv, text
, transformers
}:
mkDerivation {
pname = "hsfingerd";
@ -8,11 +9,11 @@ mkDerivation {
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
base bytestring network raw-strings-qq sqlite-simple text
transformers
aeson base bytestring containers network raw-strings-qq
sqlite-simple text transformers
];
executableHaskellDepends = [
base network optparse-applicative sqlite-simple
aeson base bytestring network optparse-applicative sqlite-simple
];
homepage = "https://git.knightsofthelambdacalcul.us/hazel/hsfingerd";
description = "A simple finger daemon in Haskell";

1
result

@ -1 +0,0 @@
/nix/store/gryj6s3dbkzplyyr9qzaasbkzcxas6iw-hsfingerd-0.1.0.0

21
src/Hsfingerd/Database.hs

@ -22,7 +22,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Typeable
import Database.SQLite.Simple hiding (bind, close)
import Database.SQLite.Simple
import Hsfingerd.User
import Text.RawString.QQ
@ -70,8 +70,8 @@ data DuplicateData = DuplicateData deriving (Eq, Show, Typeable)
instance Exception DuplicateData
getUser :: Connection -> Text -> MaybeT IO User
getUser conn username = do
results <- liftIO $ query conn getUserQuery (Only username)
getUser conn username' = do
results <- liftIO $ query conn getUserQuery (Only username')
case results of
[] -> empty
[user] -> return user
@ -81,17 +81,24 @@ createDatabase :: Connection -> IO ()
createDatabase conn = execute_ conn createUsers
addUser :: Connection -> UserRow -> IO ()
addUser conn row = executeNamed conn insertUser row
addUser conn row =
case toSQLParams row of
Just p -> executeNamed conn insertUser p
Nothing -> putStrLn "Incomplete user spec"
updateUser :: Connection -> UserRow -> IO ()
updateUser conn row = executeNamed conn modifyUser row
updateUser conn row = do
print $ toSQLParams row
case toSQLParams row of
Just p -> executeNamed conn modifyUser p
Nothing -> putStrLn "Incomplete user spec"
returnUser :: Connection -> Text -> MaybeT IO ByteString
returnUser conn username = fmap formatUser $ getUser conn (T.strip username)
returnUser conn username' = fmap formatUser $ getUser conn (T.strip username')
returnUsers :: Connection -> IO ByteString
returnUsers conn = do
rows <- query_ conn allUsers
let usernames = map uUsername rows
let usernames = map username rows
newlineSeparated = T.concat $ intersperse "\n" usernames
return $ encodeUtf8 newlineSeparated

50
src/Hsfingerd/Finger.hs

@ -1,20 +1,29 @@
{-# LANGUAGE OverloadedStrings #-}
module Hsfingerd.Finger
( handleQuery,
handleQueries,
( handleQueries,
handleModifications,
runHandler,
)
where
import Control.Monad (forever)
import Control.Monad.Trans.Maybe (runMaybeT)
import Data.Aeson (decode)
import qualified Data.ByteString.Lazy as BSL
import Data.Text.Encoding (decodeUtf8)
import Database.SQLite.Simple hiding (bind, close)
import qualified Database.SQLite.Simple as SQL
import Hsfingerd.Database
import Hsfingerd.User
import Network.Socket
import Network.Socket.ByteString (recv, sendAll)
handleQuery :: Connection -> Socket -> IO ()
type Handler = Connection -> Socket -> IO ()
type Port = String
handleQuery :: Handler
handleQuery conn soc = do
msg <- recv soc 1024
case msg of
@ -25,9 +34,42 @@ handleQuery conn soc = do
Just v' -> sendAll soc v'
Nothing -> putStrLn "Couldn't find user"
handleQueries :: Connection -> Socket -> IO ()
handleQueries :: Handler
handleQueries conn sock = forever $ do
(soc, _) <- accept sock
putStrLn "Got connection, handling query"
handleQuery conn soc
close soc
handleModify :: Handler
handleModify conn soc = do
msg <- recv soc 1024
case (decode (BSL.fromStrict msg) :: Maybe User) of
Just u -> do
print $ toUserRow u
addUser conn $ toUserRow u
Nothing -> putStrLn "Invalid JSON payload"
handleModifications :: Handler
handleModifications conn sock = forever $ do
(soc, _) <- accept sock
putStrLn "Got connection, handling modification"
handleModify conn soc
close soc
runHandler :: Handler -> Port -> IO ()
runHandler handler port = withSocketsDo $ do
addrinfos <-
getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) Nothing (Just port)
let serveraddr = head addrinfos
sock <- socket (addrFamily serveraddr) Stream defaultProtocol
bind sock (addrAddress serveraddr)
-- only one connection open
listen sock 1
conn <- open "finger.db"
handler conn sock
SQL.close conn
close sock

86
src/Hsfingerd/User.hs

@ -1,3 +1,5 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@ -6,26 +8,32 @@ module Hsfingerd.User
UserRow,
formatUser,
mkUserRow,
toUserRow
toUserRow,
toSQLParams,
toUserSerializable,
)
where
import Data.Aeson hiding (Null)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Database.SQLite.Simple
import Database.SQLite.Simple.Types
import GHC.Generics
data User = User
{ uUserId :: Integer,
uUsername :: Text,
uShell :: Text,
uHomeDirectory :: Text,
uRealName :: Text,
uPhone :: Text
{ userId :: Integer,
username :: Text,
shell :: Text,
homeDirectory :: Text,
realName :: Text,
phone :: Text
}
deriving (Eq, Show)
deriving (Eq, Show, Generic)
instance FromRow User where
fromRow = User <$> field <*> field <*> field <*> field <*> field <*> field
@ -34,21 +42,6 @@ instance ToRow User where
toRow (User id_ username shell homeDir realName phone) =
toRow (id_, username, shell, homeDir, realName, phone)
type UserRow = [NamedParam]
mkUserRow :: Text -> Text -> Text -> Text -> Text -> UserRow
mkUserRow username shell homeDir realName phone =
[ ":id" := Null,
":username" := username,
":shell" := shell,
":homeDirectory" := homeDir,
":realName" := realName,
":phone" := phone
]
toUserRow :: User -> UserRow
toUserRow User {..} = mkUserRow uUsername uShell uHomeDirectory uRealName uPhone
formatUser :: User -> ByteString
formatUser (User _ username shell homeDir realName _) =
BS.concat
@ -67,3 +60,50 @@ formatUser (User _ username shell homeDir realName _) =
]
where
e = encodeUtf8
type UserRow = Map Text Text
mkUserRow :: Text -> Text -> Text -> Text -> Text -> UserRow
mkUserRow username shell homeDir realName phone =
M.fromList $
[ (":username", username),
(":shell", shell),
(":homeDirectory", homeDir),
(":realName", realName),
(":phone", phone)
]
toUserRow :: User -> UserRow
toUserRow User {..} = mkUserRow username shell homeDirectory realName phone
toSQLParams :: UserRow -> Maybe [NamedParam]
toSQLParams mapping = do
username <- M.lookup ":username" mapping
shell <- M.lookup ":shell" mapping
homeDirectory <- M.lookup ":homeDirectory" mapping
realName <- M.lookup ":realName" mapping
phone <- M.lookup ":phone" mapping
return
[ ":id" := Null,
":username" := username,
":shell" := shell,
":homeDirectory" := homeDirectory,
":realName" := realName,
":phone" := phone
]
-- all UserSerializable IDs are zero, should not be queried to DB, only serialized
instance ToJSON User
instance FromJSON User
toUserSerializable :: UserRow -> Maybe User
toUserSerializable mapping = do
let userId = 0
username <- M.lookup ":username" mapping
shell <- M.lookup ":shell" mapping
homeDirectory <- M.lookup ":homeDirectory" mapping
realName <- M.lookup ":realName" mapping
phone <- M.lookup ":phone" mapping
return $ User {..}

Loading…
Cancel
Save