mateamt/src/Main.hs
2019-05-06 23:41:15 +02:00

105 lines
2.6 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Main where
import Servant
import Servant.Server.Experimental.Auth
import Data.Time.Clock
import Data.ByteString.Random
import Data.Set (empty)
import Database.PostgreSQL.Simple
import Network.Wai
import Network.Wai.Logger
import Network.Wai.Handler.Warp
import Opaleye
import Control.Monad.IO.Class (liftIO)
import Control.Monad (void)
import Control.Concurrent.STM.TVar
-- internal imports
import API
import Model as M
import Types
main :: IO ()
main = do
conn <- connectPostgreSQL
"host='localhost' port=5432 dbname='mateamt' user='mateamt' password='mateamt'"
store <- newTVarIO empty
execute_ conn initUser
execute_ conn initBeverage
execute_ conn initToken
withStdoutLogger $ \log -> do
let settings = setPort 3000 $ setLogger log defaultSettings
initState = ReadState
{ rsConnection = conn
, rsTicketStore = store
}
runSettings settings (app initState)
app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
app initState = serveWithContext userApi genAuthServerContext $
hoistServer (runReaderT initState) users
userApi :: Proxy UserAPI
userApi = Proxy
genAuthServerContext :: Context (AuthHandler Request Bool ': '[])
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
users :: ServerT UserAPI (ReaderT ReadState Handler)
users conn =
( userList :<|>
userNew :<|>
userUpdate
) :<|>
( authGet :<|>
authSend
)
where
userList :: Maybe Refine -> Bool -> Handler [User]
userList ref sw = liftIO $ userSelect conn ref sw
userNew :: UserSubmit -> Handler Int
userNew us = liftIO $ do
now <- getCurrentTime
randSalt <- random 8
head <$> runInsert_ conn (insertUser us (utctDay now) randSalt)
userUpdate :: (Int, UserSubmit) -> Handler ()
userUpdate (id, us) = liftIO $ do
now <- getCurrentTime
void $ runUpdate_ conn (updateUser id us (utctDay now))
authGet :: Int -> Handler AuthInfo
authGet = liftIO . getUserAuthInfo conn
authSend :: AuthRequest -> Handler AuthResult
authSend _ = liftIO $ Granted <$> AuthToken <$> random 8