datarekisteri/Server.hs

{-# 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 "base64" Data.ByteString.Base64 as B64 (decodeBase64)

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.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
    }


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 [] }