datarekisteri/Server.hs

158 lines
5.9 KiB
Haskell
Raw Normal View History

2023-01-20 09:20:06 +02:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Server where
import Relude
import "cryptonite" Crypto.Random (MonadRandom(..))
import Control.Monad.Logger (runStderrLoggingT)
import Data.Map (findWithDefault)
import Data.Text (toLower, breakOn, stripPrefix)
import Database.Persist (entityVal)
import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
import Network.Mail.Mime (renderSendMail, Address(..))
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.Gzip
import Server.API
import Server.DB
import Server.DB.Queries (getUserByEmail, getPermissions, getToken)
import Server.Types
import Server.Utils (checkPassword)
import Web.Scotty.Trans hiding (readEither)
import qualified Data.ByteString.Base64 as B64 (decode)
main :: IO ()
main = run 3100 =<< serverApp
serverApp :: IO Application
serverApp = scottyAppT runAPIM $ do
middleware $ gzip def
middleware $ cors $ const $ Just CorsResourcePolicy
{ corsOrigins = Nothing -- all
, corsMethods = ["POST"]
, corsRequestHeaders = ["Authorization"]
, corsExposedHeaders = Nothing
, corsMaxAge = Just (60*60*24)
, corsVaryOrigin = False
, corsRequireOrigin = False
, corsIgnoreFailures = False
}
post "/api" $ do
maybeAuthorization <- fmap toText <$> header "Authorization"
let maybeBasic = parseBasic maybeAuthorization
maybeBearer = parseBearer maybeAuthorization
auth = case maybeBasic of
Just _ -> authBasic maybeBasic
Nothing -> authBearer maybeBearer
auth $ do
setHeader "Content-Type" "text/json"
body >>= lift . runApp coreApp >>= raw
data BasicAuth = BasicAuth { emailAddress :: Email, password :: Text } deriving (Show)
data BearerToken = BearerToken Text deriving (Show)
parseBearer :: Maybe Text -> Maybe BearerToken
parseBearer auth = do
[authType, authData] <- words <$> auth
guard $ toLower authType == "bearer"
pure $ BearerToken authData
authBearer :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a
authBearer Nothing m = m
authBearer (Just (BearerToken bearer)) m = do
token <- lift $ getToken bearer
let permissions = fromMaybe mempty $ token >>= readPermission . dBTokenPermissions . entityVal
flip local m $ \state -> state
{ stateCurrentUser = fromDBKey . dBTokenUid . entityVal <$> token
, statePermissions = permissions
}
parseBasic :: Maybe Text -> Maybe BasicAuth
parseBasic txt = do
[authType, authData] <- words <$> txt
guard $ toLower authType == "basic"
(email, password) <- rightToMaybe $
breakOn' ":" . decodeUtf8 <$> B64.decode (encodeUtf8 authData)
emailAddress <- toEmail email
pure $ BasicAuth {..}
where breakOn' x xs = let (fst, snd) = breakOn x xs
in (fst, fromMaybe "" $ stripPrefix x snd)
authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
authBasic Nothing m = m
authBasic (Just basic) m = do
user <- verifyBasic basic
permissions <- maybe (pure mempty)
(fmap (fromMaybe mempty . (>>= readPermission)) . lift . getPermissions) user
flip local m $ \state -> state
{ stateCurrentUser = user
, statePermissions = permissions
}
-- TODO Refact, no need to convert to id and rerequest permissions
verifyBasic :: BasicAuth -> ActionT LText APIM (Maybe UserID)
verifyBasic BasicAuth {..} = do
user <- lift $ getUserByEmail emailAddress
if maybe False (checkPassword password . dBUserPasswordCrypt . entityVal) user
then pure $ entityToID <$> user
else pure Nothing
newtype APIM a = APIM (ReaderT RequestState IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState)
data RequestState = RequestState
{ stateCurrentUser :: Maybe UserID
, statePermissions :: Map Scope Permission
}
instance MonadTime APIM where
currentTime = liftIO currentTime
instance MonadDB APIM where
runQuery = liftIO . runStderrLoggingT . withPostgresqlConn "postgres:///id.rekisteri" . runSqlConn
instance MonadEmail APIM where
sendEmail = liftIO . renderSendMail
fromAddress = pure $ Address Nothing "id@datat.fi"
instance MonadRequest APIM where
currentUser = asks stateCurrentUser
instance MonadRandom APIM where
getRandomBytes = liftIO . getRandomBytes
instance MonadPermissions APIM where
currentPermissions = show <$> asks statePermissions
defaultPermissions = pure $ show $ (fromList [(OwnProfile, ReadWrite)] :: Map Scope Permission)
toPermissions = pure . fmap show . readPermission
hasPermission scope permission = (>= permission) <$> findPermission scope
where findPermission :: Scope -> APIM Permission
findPermission scope@(Profile user) = selfPermissions scope user OwnProfile
findPermission scope@(Tokens user) = selfPermissions scope user OwnTokens
findPermission scope = findPermission' scope <$> asks statePermissions
findPermission' :: Scope -> Map Scope Permission -> Permission
findPermission' = findWithDefault None
selfPermissions :: Scope -> UserID -> Scope -> APIM Permission
selfPermissions scope user own = do
isSelf <- (Just user ==) <$> currentUser
let f = if isSelf then max <$> findPermission' own <*> findPermission' scope
else findPermission' scope
f <$> asks statePermissions
readPermission :: Text -> Maybe (Map Scope Permission)
readPermission = rightToMaybe . readEither . toString
runAPIM :: APIM a -> IO a
runAPIM (APIM m) = runReaderT m RequestState { stateCurrentUser = Nothing, statePermissions = fromList [] }