Add paste/account anagement.

src/API.hs

@@ -4,7 +4,6 @@
 module API where
 
 import Servant
-import Control.Monad.Except
 import Database.Persist.Sqlite
 import Control.Monad.Logger
 
@@ -14,20 +13,37 @@ 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 = 
-          Capture "username" Text :> Capture "pasteName" Text :> Get '[JSON] Paste
+          PasteCapture (Get '[JSON] SanitizedPaste)
-    :<|> "raw" :> Capture "username" Text :> Capture "pasteName" Text :> Get '[PlainText] Text
+     :<|> "raw" :> PasteCapture (Get '[PlainText] Text)
 
-type API = GetPasteAPI
+type RequiresAuth a =
+    BasicAuth "pastecan" (Entity User) :> a
 
-pasteServer :: ServerT GetPasteAPI App
+type UpdatePasteAPI = 
-pasteServer = getPasteData :<|> getPasteRaw
+    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 >>= 
@@ -35,40 +51,115 @@ justOrError e m =
             Just x -> return x
             Nothing -> throwError e)
 
+-- justOrError specialised for Error 404
 justOr404 :: App (Maybe a) -> App a
 justOr404 = justOrError err404
 
-basicAuthCheck :: HandlerConfig -> BasicAuthCheck User
+-- 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 User)
+            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 _ userData) -> do
+                    Just (Entity uid userData) -> do
                         let correctPassword = encodeUtf8 $ userPassword userData
                         
                         if verifyPassword suppliedPassword correctPassword then
-                            return $ Authorized userData
+                            return $ Authorized $ Entity uid userData
                         else
                             return BadPassword
                     Nothing -> return NoSuchUser
 
-getPasteData :: Text -> Text -> App Paste
+-- 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
-    userEntity <- justOr404 $ runDB $ getBy $ Username username
+    (Entity uid _) <- justOr404 $ getUserByName username
-    let (Entity uid _) = userEntity
+    (Entity _ paste) <- justOr404 $ runDB $ getBy (PasteNamePoster name uid)
-    pasteEntity <- justOr404 $ runDB $ getBy (PasteNamePoster name uid)
+    return $ sanitizePaste paste
-    let (Entity _ paste) = pasteEntity
-    return paste
 
 getPasteRaw :: Text -> Text -> App Text
-getPasteRaw u n = pasteContent <$> getPasteData u n
+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) pasteServer
+server cfg = enter (appToServer cfg) (updatePasteServer :<|> getPasteServer :<|> accountServer)
 
 proxy :: Proxy API
 proxy = Proxy
@@ -78,7 +169,7 @@ mkApp path = do
     pool <- runStderrLoggingT $ createSqlitePool (T.pack path) 5
     runSqlPool doMigrations pool
     let cfg = HandlerConfig pool
-    return $ serve proxy (server cfg)
+    return $ serveWithContext proxy (basicAuthContext cfg) (server cfg)
 
 runApp :: Int -> FilePath -> IO ()
 runApp port dbFile =

src/Model.hs

@@ -1,14 +1,15 @@
-{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Model where
 
@@ -18,6 +19,7 @@ import Database.Persist.Sql
 import Database.Persist.TH
 import qualified Data.Text as T
 import Data.Text (Text(..))
+import Data.Aeson
 
 import PasteType
 
@@ -26,7 +28,7 @@ User json
     username Text
     password Text
     Username username
-    deriving Show Generic
+    deriving Show Generic Eq
 
 Paste json
     poster UserId
@@ -34,8 +36,39 @@ Paste json
     content Text
     type PasteType
     PasteNamePoster name poster
-    deriving Show Generic
+    deriving Show Generic Eq
 |]
 
+data SanitizedPaste = SanitizedPaste
+    { name :: Text
+    , content :: Text
+    , type_ :: PasteType
+    } deriving (Show, Generic, Eq)
+
+-- Make the API slightly nicer by not having an ugly underscore on type_
+instance ToJSON SanitizedPaste where
+    toJSON (SanitizedPaste name content type_) = object ["name" .= name, "content" .= content, "type" .= type_]
+
+instance FromJSON SanitizedPaste where
+    parseJSON = withObject "SanitizedPaste" $ \v -> SanitizedPaste
+        <$> v .: "name"
+        <*> v .: "content"
+        <*> v .: "type"
+
+sanitizePaste :: Paste -> SanitizedPaste
+sanitizePaste Paste{..} = SanitizedPaste
+    { name = pasteName
+    , content = pasteContent
+    , type_ = pasteType
+    }
+
+attachPoster :: Key User -> SanitizedPaste -> Paste
+attachPoster uid SanitizedPaste{..} = Paste
+    { pasteName = name
+    , pasteContent = content
+    , pasteType = type_
+    , pastePoster = uid
+    }
+
 doMigrations :: SqlPersistT IO ()
 doMigrations = runMigration migrateAll

src/PasteType.hs

@@ -2,6 +2,7 @@
 
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module PasteType where
 
@@ -11,7 +12,10 @@ import Data.Aeson
 
 data PasteType = PlainText deriving (Show, Read, Eq, Generic)
 
-instance FromJSON PasteType
+instance FromJSON PasteType where
-instance ToJSON PasteType
+    parseJSON (String "plain") = return PlainText
+
+instance ToJSON PasteType where
+    toJSON PlainText = "plain"
 
 derivePersistField "PasteType"