pastecan/src/API.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}

module API where

import Servant
import Database.Persist.Sqlite
import Control.Monad.Logger

import Crypto.PasswordStore

import qualified Data.Text as T
import Data.Text (Text(..))
import Data.Text.Encoding

import Control.Monad.IO.Class (liftIO)

import Network.Wai.Handler.Warp as Warp

import Model
import Config

type PasteCapture a = 
    Capture "username" Text :> Capture "pasteName" Text :> a

type GetPasteAPI = 
          PasteCapture (Get '[JSON] SanitizedPaste)
     :<|> "raw" :> PasteCapture (Get '[PlainText] Text)

type RequiresAuth a =
    BasicAuth "pastecan" (Entity User) :> a

type UpdatePasteAPI = 
    RequiresAuth (
              PasteCapture (Delete '[PlainText] NoContent)
         :<|> PasteCapture (ReqBody '[JSON] SanitizedPaste :> Put '[PlainText] NoContent))

type AccountsAPI = 
    "account" :> (
             ReqBody '[JSON] User :> Post '[JSON] Bool
        :<|> RequiresAuth (Delete '[JSON] NoContent))

type API = 
     UpdatePasteAPI :<|> GetPasteAPI :<|> AccountsAPI

-- If m is not Just x, will throw a Servant error. Otherwise, will return x.
justOrError :: ServantErr -> App (Maybe a) -> App a
justOrError e m =
    m >>= 
        (\w -> case w of
            Just x -> return x
            Nothing -> throwError e)

-- justOrError specialised for Error 404
justOr404 :: App (Maybe a) -> App a
justOr404 = justOrError err404

-- Throws a Servant error if b is True.
errIf :: ServantErr -> Bool -> App ()
errIf e b = if b then throwError e else return ()

-- errIf specialised for Error 403
err403If :: Bool -> App ()
err403If = errIf err403

-- Checks BasicAuth credentials
basicAuthCheck :: HandlerConfig -> BasicAuthCheck (Entity User)
basicAuthCheck HandlerConfig{db = db} =
    BasicAuthCheck check
        where
            check :: BasicAuthData -> IO (BasicAuthResult (Entity User))
            check (BasicAuthData username suppliedPassword) = do
                -- Annoyingly, we can't use the App monad here.
                userEntity <- flip runSqlPool db $ getBy $ Username (decodeUtf8 username)
                case userEntity of
                    Just (Entity uid userData) -> do
                        let correctPassword = encodeUtf8 $ userPassword userData
                        
                        if verifyPassword suppliedPassword correctPassword then
                            return $ Authorized $ Entity uid userData
                        else
                            return BadPassword
                    Nothing -> return NoSuchUser

-- A Context with a BasicAuthCheck in it
basicAuthContext :: HandlerConfig -> Context (BasicAuthCheck (Entity User) ': '[])
basicAuthContext cfg = basicAuthCheck cfg :. EmptyContext

getUserByName :: Text -> App (Maybe (Entity User))
getUserByName n = runDB $ getBy $ Username n

getPasteData :: Text -> Text -> App SanitizedPaste
getPasteData username name = do
    (Entity uid _) <- justOr404 $ getUserByName username
    (Entity _ paste) <- justOr404 $ runDB $ getBy (PasteNamePoster name uid)
    return $ sanitizePaste paste

getPasteRaw :: Text -> Text -> App Text
getPasteRaw u n = content <$> getPasteData u n

getPasteServer :: ServerT GetPasteAPI App
getPasteServer = getPasteData :<|> getPasteRaw

requireUserHasUsername :: User -> Text -> App ()
requireUserHasUsername user username = err403If $ (userUsername user) /= username

deletePaste :: (Entity User) -> Text -> Text -> App NoContent
deletePaste (Entity uid user) username pasteName = do
    requireUserHasUsername user username

    runDB $ deleteBy $ PasteNamePoster pasteName uid

    return NoContent

updatePaste :: (Entity User) -> Text -> Text -> SanitizedPaste -> App NoContent
updatePaste (Entity uid user) username pasteName newPaste = do
    requireUserHasUsername user username

    let paste = attachPoster uid newPaste

    e <- runDB $ getBy $ PasteNamePoster pasteName uid

    case e of
        Just (Entity pasteId _) -> -- Paste already exists in database
            runDB $ replace pasteId paste
        Nothing -> do -- Paste is new
            runDB $ insert paste
            return ()

    return NoContent

updatePasteServer :: ServerT UpdatePasteAPI App
updatePasteServer user = deletePaste user :<|> updatePaste user

createAccount :: User -> App Bool
createAccount u = do
    -- TODO: find more typesafe way to do this
    hashedPass <- liftIO $ decodeUtf8 <$> makePassword (encodeUtf8 $ userPassword u) 17
    let account = u {userPassword = hashedPass}

    maybeUser <- getUserByName (userUsername account)

    case maybeUser of
        Just (Entity _ _) ->
            return False -- User by that name already exists - disallow creation
        Nothing -> do
            runDB $ insert account
            return True

deleteAccount :: Entity User -> App NoContent
deleteAccount (Entity uid _) = do
    runDB $ do
        deleteWhere [PastePoster ==. uid]
        delete uid

    return NoContent

accountServer :: ServerT AccountsAPI App
accountServer = createAccount :<|> deleteAccount

server :: HandlerConfig -> Server API
server cfg = enter (appToServer cfg) (updatePasteServer :<|> getPasteServer :<|> accountServer)

proxy :: Proxy API
proxy = Proxy

mkApp :: FilePath -> IO Application
mkApp path = do
    pool <- runStderrLoggingT $ createSqlitePool (T.pack path) 5
    runSqlPool doMigrations pool
    let cfg = HandlerConfig pool
    return $ serveWithContext proxy (basicAuthContext cfg) (server cfg)

runApp :: Int -> FilePath -> IO ()
runApp port dbFile =
    Warp.run port =<< mkApp dbFile