85 lines
2.6 KiB
Haskell
85 lines
2.6 KiB
Haskell
{-# 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 |