Initial commit: paste-getting only, no upload.

src/API.hs

@@ -0,0 +1,62 @@
+{-# 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

src/Config.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Config where
+
+import Control.Monad.Reader
+import Control.Monad.Except
+
+import Database.Persist
+import Database.Persist.Sql
+import Servant
+
+data HandlerConfig = HandlerConfig
+    { db :: ConnectionPool
+    }
+
+newtype App a = App
+    { runApp :: ReaderT HandlerConfig Handler a
+    } deriving (Functor, Applicative, Monad, MonadReader HandlerConfig, MonadError ServantErr, MonadIO)
+
+appToServer :: HandlerConfig -> App :~> Handler
+appToServer cfg = NT (flip runReaderT cfg . runApp)
+
+runDB :: (MonadReader HandlerConfig m, MonadIO m) => SqlPersistT IO b -> m b
+runDB query = do
+    db <- asks db
+    liftIO $ runSqlPool query db

src/Main.hs

@@ -0,0 +1,9 @@
+module Main where
+
+import Network.Wai
+import Network.Wai.Handler.Warp
+
+import API
+
+main :: IO ()
+main = runApp 3000 "pastecan.db"

src/Model.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleInstances          #-}
+
+module Model where
+
+import GHC.Generics
+import Database.Persist
+import Database.Persist.Sql
+import Database.Persist.TH
+
+import PasteType
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+User json
+    username String
+    Username username
+    deriving Show Generic
+
+Paste json
+    parent UserId
+    name String
+    content String
+    type PasteType
+    deriving Show Generic
+|]
+
+doMigrations :: SqlPersistT IO ()
+doMigrations = runMigration migrateAll

src/PasteType.hs

@@ -0,0 +1,17 @@
+-- This module only exists because of the GHC stage restriction.
+
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module PasteType where
+
+import Database.Persist.TH
+import GHC.Generics
+import Data.Aeson
+
+data PasteType = PlainText deriving (Show, Read, Eq, Generic)
+
+instance FromJSON PasteType
+instance ToJSON PasteType
+
+derivePersistField "PasteType"