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)
|
|
|
|
app initState = serveWithContext userApi genAuthServerContext $
|
2019-05-08 23:24:58 +00:00
|
|
|
hoistServer userApi (`runReaderT` initState) users
|
2019-04-15 20:23:25 +00:00
|
|
|
|
|
|
|
userApi :: Proxy UserAPI
|
|
|
|
userApi = Proxy
|
|
|
|
|
2019-04-17 05:51:15 +00:00
|
|
|
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
|
|
|
|
|
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]
|
|
|
|
userList ref sw = liftIO $ do
|
|
|
|
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-04-15 20:23:25 +00:00
|
|
|
userNew us = liftIO $ do
|
|
|
|
now <- getCurrentTime
|
2019-04-21 15:27:15 +00:00
|
|
|
randSalt <- random 8
|
2019-05-08 23:24:58 +00:00
|
|
|
conn <- rsConnection <$> ask
|
2019-04-21 15:27:15 +00:00
|
|
|
head <$> 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-04-16 04:23:08 +00:00
|
|
|
userUpdate (id, us) = liftIO $ do
|
|
|
|
now <- getCurrentTime
|
2019-05-08 23:24:58 +00:00
|
|
|
conn <- rsConnection <$> ask
|
2019-04-16 04:23:08 +00:00
|
|
|
void $ 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-04-21 15:27:15 +00:00
|
|
|
authSend _ = liftIO $ Granted <$> AuthToken <$> random 8
|