mateamt/src/Main.hs

124 lines
2.9 KiB
Haskell
Raw Normal View History

2019-04-15 20:23:25 +00:00
{-# LANGUAGE OverloadedStrings #-}
2019-04-17 05:51:15 +00:00
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
2019-03-22 21:34:01 +00:00
module Main where
2019-04-15 20:23:25 +00:00
import Servant
2019-04-17 05:51:15 +00:00
import Servant.Server.Experimental.Auth
2019-04-15 20:23:25 +00:00
import Data.Time.Clock
2019-04-21 15:27:15 +00:00
import Data.ByteString.Random
2019-05-06 21:41:05 +00:00
import Data.Set (empty)
2019-04-15 20:23:25 +00:00
import Database.PostgreSQL.Simple
2019-04-16 11:30:16 +00:00
import Network.Wai
import Network.Wai.Logger
2019-04-15 20:23:25 +00:00
import Network.Wai.Handler.Warp
import Opaleye
import Control.Monad.IO.Class (liftIO)
import Control.Monad (void)
2019-05-08 23:24:58 +00:00
import Control.Monad.Reader
2019-05-06 21:41:05 +00:00
import Control.Concurrent.STM.TVar
2019-04-15 20:23:25 +00:00
-- internal imports
import API
import Model as M
import Types
2019-03-22 21:34:01 +00:00
main :: IO ()
2019-04-15 20:23:25 +00:00
main = do
conn <- connectPostgreSQL
"host='localhost' port=5432 dbname='mateamt' user='mateamt' password='mateamt'"
2019-05-06 21:41:05 +00:00
store <- newTVarIO empty
2019-04-16 11:03:07 +00:00
execute_ conn initUser
2019-04-16 12:02:41 +00:00
execute_ conn initBeverage
2019-04-21 15:27:15 +00:00
execute_ conn initToken
2019-04-16 11:30:16 +00:00
withStdoutLogger $ \log -> do
let settings = setPort 3000 $ setLogger log defaultSettings
2019-05-06 21:41:05 +00:00
initState = ReadState
{ rsConnection = conn
, rsTicketStore = store
}
runSettings settings (app initState)
2019-04-15 20:23:25 +00:00
2019-05-06 21:41:05 +00:00
app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
2019-05-10 12:10:11 +00:00
app initState = serveWithContext userApi genAuthServerContext $
2019-05-09 14:53:19 +00:00
hoistServerWithContext
userApi
authProxy
(`runReaderT` initState)
users
-- hoistServerWithContext
-- userApi
-- genAuthServerContext
-- (`runReaderT` initState)
-- users
2019-04-15 20:23:25 +00:00
userApi :: Proxy UserAPI
userApi = Proxy
2019-05-10 12:10:11 +00:00
authProxy :: Proxy '[ AuthHandler Request Bool ]
2019-05-09 14:53:19 +00:00
authProxy = Proxy
2019-05-10 12:10:11 +00:00
genAuthServerContext :: Context '[ AuthHandler Request Bool ]
2019-04-17 05:51:15 +00:00
genAuthServerContext = authHandler Servant.:. EmptyContext
type instance AuthServerData (AuthProtect "header-auth") = Bool
authHandler :: AuthHandler Request Bool
authHandler = mkAuthHandler handler
where
handler req = do
let headers = requestHeaders req
res = case lookup "Authorization" headers of
Just _ -> True
_ -> False
return res
2019-05-06 21:41:05 +00:00
users :: ServerT UserAPI (ReaderT ReadState Handler)
2019-05-08 23:24:58 +00:00
users =
2019-04-17 08:45:48 +00:00
( userList :<|>
userNew :<|>
userUpdate
) :<|>
( authGet :<|>
authSend
)
2019-04-15 20:23:25 +00:00
where
2019-05-08 23:24:58 +00:00
userList :: Maybe Refine -> Bool -> MateHandler [User]
2019-05-09 14:53:19 +00:00
userList ref sw = do
2019-05-08 23:24:58 +00:00
conn <- rsConnection <$> ask
userSelect conn ref sw
2019-04-17 08:45:48 +00:00
2019-05-08 23:24:58 +00:00
userNew :: UserSubmit -> MateHandler Int
2019-05-10 12:10:11 +00:00
userNew us = do
2019-05-09 14:53:19 +00:00
now <- liftIO $ getCurrentTime
randSalt <- liftIO $ random 8
2019-05-08 23:24:58 +00:00
conn <- rsConnection <$> ask
2019-05-09 14:53:19 +00:00
head <$> (liftIO $ runInsert_ conn (insertUser us (utctDay now) randSalt))
2019-04-17 08:45:48 +00:00
2019-05-08 23:24:58 +00:00
userUpdate :: (Int, UserSubmit) -> MateHandler ()
2019-05-09 14:53:19 +00:00
userUpdate (id, us) = do
now <- liftIO $ getCurrentTime
2019-05-08 23:24:58 +00:00
conn <- rsConnection <$> ask
2019-05-09 14:53:19 +00:00
void $ liftIO $ runUpdate_ conn (updateUser id us (utctDay now))
2019-04-17 08:45:48 +00:00
2019-05-08 23:24:58 +00:00
authGet :: Int -> MateHandler AuthInfo
authGet id =
getUserAuthInfo id
2019-04-17 08:45:48 +00:00
2019-05-08 23:24:58 +00:00
authSend :: AuthRequest -> MateHandler AuthResult
2019-05-10 12:10:11 +00:00
authSend = processAuthRequest