207 lines
8.0 KiB
Haskell
207 lines
8.0 KiB
Haskell
{-# 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 (renderSendMailCustom, Address(..))
|
|
import Network.Wai (Application)
|
|
import Network.Wai.Handler.Warp (Port, 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 System.Directory (findExecutable)
|
|
import System.Process (callProcess)
|
|
import Options.Applicative hiding (header)
|
|
import qualified Options.Applicative as O
|
|
import Web.Scotty.Trans hiding (readEither)
|
|
import qualified "base64" Data.ByteString.Base64 as B64 (decodeBase64)
|
|
import Paths_datarekisteri
|
|
|
|
main :: IO ()
|
|
main = do
|
|
config <- readConfig >>= checkSendmailPath
|
|
runMigrations (configDbUrl config)
|
|
serverApp config >>= run 3100
|
|
|
|
readConfig :: IO Config
|
|
readConfig = do
|
|
execParser $ info (configOpts <**> helper)
|
|
(fullDesc <> progDesc "Serve a GraphQL API for datarekisteri"
|
|
<> O.header "Backend API server for datarekisteri")
|
|
|
|
checkSendmailPath :: Config -> IO Config
|
|
checkSendmailPath config = do
|
|
sendmailPath <- maybe (error "Sendmail command or file not found!") pure =<<
|
|
findExecutable (configSendmail config)
|
|
pure $ config {configSendmail = sendmailPath}
|
|
|
|
configOpts :: Parser Config
|
|
configOpts = Config
|
|
<$> strOption (long "sendmail" <> short 'm' <> metavar "COMMAND" <> value "sendmail" <> help "Sendmail command")
|
|
<*> (Address
|
|
<$> optional (strOption (long "sender-name" <> short 'n' <> metavar "NAME" <> help "Display name for email address"))
|
|
<*> strOption (long "address" <> short 'a' <> metavar "EMAIL" <> help "Email address to send mail"))
|
|
<*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3100 <> help "Port to listen on")
|
|
<*> strOption (long "db-url" <> short 'u' <> metavar "URL" <> value "postgres:///id.rekisteri" <> help "Postgresql database url")
|
|
|
|
runMigrations :: Text -> IO ()
|
|
runMigrations dbUrl = do
|
|
migrationsPath <- getDataFileName "db/migrations"
|
|
callProcess "dbmate" ["--url", toString dbUrl, "--migrations-dir", migrationsPath, "up"]
|
|
|
|
serverApp :: Config -> IO Application
|
|
serverApp config = scottyAppT (runAPIM config) $ 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.decodeBase64 (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
|
|
, stateConfig :: Config
|
|
}
|
|
|
|
data Config = Config
|
|
{ configSendmail :: FilePath
|
|
, configEmailAddress :: Address
|
|
, configPort :: Port
|
|
, configDbUrl :: Text
|
|
}
|
|
|
|
instance MonadTime APIM where
|
|
currentTime = liftIO currentTime
|
|
|
|
instance MonadDB APIM where
|
|
runQuery query = do
|
|
dbUrl <- asks $ configDbUrl . stateConfig
|
|
liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query
|
|
|
|
instance MonadEmail APIM where
|
|
sendEmail email = do
|
|
sendmailPath <- asks $ configSendmail . stateConfig
|
|
liftIO $ renderSendMailCustom sendmailPath ["-t"] email
|
|
fromAddress = asks $ configEmailAddress . stateConfig
|
|
|
|
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 :: Config -> APIM a -> IO a
|
|
runAPIM config (APIM m) = runReaderT m RequestState
|
|
{ stateCurrentUser = Nothing
|
|
, statePermissions = fromList []
|
|
, stateConfig = config
|
|
}
|