62 lines
1.7 KiB
Haskell
62 lines
1.7 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module API where
|
|
|
|
import Servant
|
|
import Control.Monad.Except
|
|
import Database.Persist.Sqlite
|
|
import Data.String.Conversions
|
|
import Control.Monad.Logger
|
|
|
|
import Network.Wai.Handler.Warp as Warp
|
|
|
|
import Model
|
|
import Config
|
|
|
|
type GetPasteAPI =
|
|
Capture "username" String :> Capture "pasteName" String :> Get '[JSON] Paste
|
|
:<|> "raw" :> Capture "username" String :> Capture "pasteName" String :> Get '[PlainText] String
|
|
|
|
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
|
|
|
|
getPasteData :: String -> String -> App Paste
|
|
getPasteData username name = do
|
|
userEntity <- justOr404 $ runDB $ getBy $ Username username
|
|
let (Entity uid _) = userEntity
|
|
pasteEntity <- justOr404 $ runDB $ selectFirst [PasteParent ==. uid, PasteName ==. name] []
|
|
let (Entity _ paste) = pasteEntity
|
|
return paste
|
|
|
|
getPasteRaw :: String -> String -> App String
|
|
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 (cs 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 |