From a61b031d993aa70434966eab3325a0f7b5bb9894 Mon Sep 17 00:00:00 2001 From: osmarks Date: Fri, 22 Sep 2017 22:25:13 +0100 Subject: [PATCH] Add paste/account anagement. --- src/API.hs | 129 ++++++++++++++++++++++++++++++++++++++++------- src/Model.hs | 57 ++++++++++++++++----- src/PasteType.hs | 8 ++- 3 files changed, 161 insertions(+), 33 deletions(-) diff --git a/src/API.hs b/src/API.hs index 2358f85..5b620be 100644 --- a/src/API.hs +++ b/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 - :<|> "raw" :> Capture "username" Text :> Capture "pasteName" Text :> Get '[PlainText] Text + PasteCapture (Get '[JSON] SanitizedPaste) + :<|> "raw" :> PasteCapture (Get '[PlainText] Text) -type API = GetPasteAPI +type RequiresAuth a = + BasicAuth "pastecan" (Entity User) :> a -pasteServer :: ServerT GetPasteAPI App -pasteServer = getPasteData :<|> getPasteRaw +type UpdatePasteAPI = + 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 - let (Entity uid _) = userEntity - pasteEntity <- justOr404 $ runDB $ getBy (PasteNamePoster name uid) - let (Entity _ paste) = pasteEntity - return paste + (Entity uid _) <- justOr404 $ getUserByName username + (Entity _ paste) <- justOr404 $ runDB $ getBy (PasteNamePoster name uid) + return $ sanitizePaste 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 = diff --git a/src/Model.hs b/src/Model.hs index 71644c7..7b66194 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# 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 \ No newline at end of file diff --git a/src/PasteType.hs b/src/PasteType.hs index 43d4f62..f4f918c 100644 --- a/src/PasteType.hs +++ b/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 ToJSON PasteType +instance FromJSON PasteType where + parseJSON (String "plain") = return PlainText + +instance ToJSON PasteType where + toJSON PlainText = "plain" derivePersistField "PasteType" \ No newline at end of file