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

module API where

import Servant
import Control.Monad.Except
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 Network.Wai.Handler.Warp as Warp

import Model
import Config

type GetPasteAPI = 
          Capture "username" Text :> Capture "pasteName" Text :> Get '[JSON] Paste
    :<|> "raw" :> Capture "username" Text :> Capture "pasteName" Text :> Get '[PlainText] Text

type API = GetPasteAPI

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

justOrError :: ServantErr -> App (Maybe a) -> App a
justOrError e m =
    m >>= 
        (\w -> case w of
            Just x -> return x
            Nothing -> throwError e)

justOr404 :: App (Maybe a) -> App a
justOr404 = justOrError err404

basicAuthCheck :: HandlerConfig -> BasicAuthCheck User
basicAuthCheck HandlerConfig{db = db} =
    BasicAuthCheck check
        where
            check :: BasicAuthData -> IO (BasicAuthResult 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 _ userData) -> do
                        let correctPassword = encodeUtf8 $ userPassword userData
                        
                        if verifyPassword suppliedPassword correctPassword then
                            return $ Authorized userData
                        else
                            return BadPassword
                    Nothing -> return NoSuchUser

getPasteData :: Text -> Text -> App Paste
getPasteData username name = do
    userEntity <- justOr404 $ runDB $ getBy $ Username username
    let (Entity uid _) = userEntity
    pasteEntity <- justOr404 $ runDB $ getBy (PasteNamePoster name uid)
    let (Entity _ paste) = pasteEntity
    return paste

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

server :: HandlerConfig -> Server API
server cfg = enter (appToServer cfg) pasteServer

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 $ serve proxy (server cfg)

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