From 5727ea55749e5575a019b32cede3e9a5a03896c0 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Mon, 12 Nov 2018 21:32:42 +0200 Subject: [PATCH] Docs support --- backend/backend.cabal | 2 + backend/src/API.hs | 6 +-- backend/src/API/Books.hs | 88 ++++++++++++++++++-------------- backend/src/API/Catalogue.hs | 18 ++++++- backend/src/API/Channels.hs | 67 +++++++++++++----------- backend/src/API/Users.hs | 30 ++++++----- backend/src/Database/Schema.hs | 83 ++++++++++++++++-------------- backend/src/Server.hs | 60 ++++++++++++---------- backend/src/Server/Auth.hs | 48 +++++++++-------- migrations/V1.2__unique_tags.sql | 1 + 10 files changed, 235 insertions(+), 168 deletions(-) create mode 100644 migrations/V1.2__unique_tags.sql diff --git a/backend/backend.cabal b/backend/backend.cabal index 2103278..cab10ec 100644 --- a/backend/backend.cabal +++ b/backend/backend.cabal @@ -68,6 +68,7 @@ executable backend , servant , servant-auth , servant-auth-server + , servant-auth-docs , servant-docs , servant-lucid , servant-multipart @@ -124,6 +125,7 @@ test-suite spec , servant-auth , servant-auth-server , servant-docs + , servant-auth-docs , servant-lucid , servant-multipart , servant-server diff --git a/backend/src/API.hs b/backend/src/API.hs index 3186b6a..7ac4389 100644 --- a/backend/src/API.hs +++ b/backend/src/API.hs @@ -25,16 +25,14 @@ import qualified API.Catalogue as Catalogue data Index = Index -type API = Get '[HTML] (AppView Index) - :<|> Users.API +type API = Users.API :<|> "api" :> "current" :> Channels.API :<|> "api" :> "current" :> Books.API :<|> "api" :> "1" :> Catalogue.VersionedAPI 1 :<|> "api" :> "current" :> Catalogue.VersionedAPI 1 handler :: ServerT API AppM -handler = indexHandler - :<|> Users.handler +handler = Users.handler :<|> Channels.handler :<|> Books.handler :<|> Catalogue.handler diff --git a/backend/src/API/Books.hs b/backend/src/API/Books.hs index ad7fcea..bb13e42 100644 --- a/backend/src/API/Books.hs +++ b/backend/src/API/Books.hs @@ -1,53 +1,58 @@ -{-# Language DuplicateRecordFields #-} -{-# Language DataKinds #-} -{-# Language TypeFamilies #-} -{-# Language TypeOperators #-} -{-# Language NoImplicitPrelude #-} -{-# Language MultiParamTypeClasses #-} -{-# Language OverloadedStrings #-} -{-# Language TemplateHaskell #-} -{-# Language QuasiQuotes #-} -{-# Language RecordWildCards #-} -{-# Language DeriveGeneric #-} -{-# Language FlexibleInstances #-} -{-# Language TypeApplications #-} -{-# Language DataKinds #-} -{-# Language NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module API.Books where import ClassyPrelude import Control.Lens -import Control.Monad.Catch (throwM, MonadThrow) +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Trans.Maybe +import Crypto.Hash (digestFromByteString) import Data.Aeson +import Data.ByteArray (convert) import Data.Generics.Product import Database import Database.Book import Database.Channel import Database.Tag -import Servant hiding (contentType) -import Servant.Auth as SA +import qualified Datastore as DS +import Servant hiding (contentType) +import Servant.Auth as SA +import qualified Servant.Docs as Docs import Server.Auth import Types -import Control.Monad.Trans.Maybe - -import qualified Datastore as DS -import Data.ByteArray (convert) -import Crypto.Hash (digestFromByteString) - -data JsonBook = JsonBook { identifier :: BookID +data JsonBook = JsonBook { identifier :: BookID , contentType :: Text - , title :: Text + , title :: Text , description :: Maybe Text - , channels :: [Text] - , tags :: [Text] } + , channels :: [Text] + , tags :: [Text] } deriving (Generic, Show, Eq) +instance Docs.ToSample JsonBook where + toSamples _ = [("Book", JsonBook 13 "epub" "title" (Just "Description") [] [])] + +instance Docs.ToSample PostBook where + toSamples _ = [("Book", PostBook "epub" "title" (Just "Description") [] [])] + data PostBook = PostBook { contentType :: Text - , title :: Text + , title :: Text , description :: Maybe Text - , channels :: [Text] - , tags :: [Text] } + , channels :: [Text] + , tags :: [Text] } deriving (Generic, Show, Eq) @@ -58,13 +63,21 @@ instance FromJSON PostBook type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI +instance Docs.ToCapture (Capture "book_id" BookID) where + toCapture _ = Docs.DocCapture "book_id" "The book id" + type BaseAPI = "books" :> Get '[JSON] [JsonBook] :<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook :<|> "books" :> Capture "book_id" BookID :> "meta" :> ReqBody '[JSON] JsonBook :> Put '[JSON] JsonBook - :<|> "books" :> Capture "book_id" BookID :> ReqBody '[OctetStream] ByteString :> Put '[JSON] NoContent + :<|> "books" :> Capture "book_id" BookID :> ReqBody '[OctetStream] FileContent :> Put '[JSON] NoContent :<|> GetBook -type GetBook = "books" :> Capture "book_id" BookID :> Get '[OctetStream] ByteString +newtype FileContent = FileContent { getFileContent :: ByteString } deriving (MimeUnrender OctetStream, MimeRender OctetStream ) + +instance Docs.ToSample FileContent where + toSamples _ = [("File contents", FileContent "bytes here and there")] + +type GetBook = "books" :> Capture "book_id" BookID :> Get '[OctetStream] FileContent handler :: ServerT API AppM handler user = listBooksHandler user @@ -73,12 +86,12 @@ handler user = listBooksHandler user :<|> putBookContentHandler user :<|> getBookContentHandler user -getBookContentHandler :: AuthResult SafeUser -> BookID -> AppM ByteString +getBookContentHandler :: AuthResult SafeUser -> BookID -> AppM FileContent getBookContentHandler auth bookId = requireBookOwner auth bookId $ \SafeUser{username} -> do content <- runMaybeT $ do Book{contentHash=mHash} <- MaybeT $ runDB (getBook bookId username) contentHash <- MaybeT $ return (mHash >>= digestFromByteString . unHex) - MaybeT $ DS.get contentHash + FileContent <$> MaybeT (DS.get contentHash) maybe (throwM err404) return content requireBookOwner :: AuthResult SafeUser -> BookID -> (SafeUser -> AppM a) -> AppM a @@ -87,8 +100,9 @@ requireBookOwner auth bookId f = flip requireLoggedIn auth $ \u@SafeUser{usernam unless exists $ throwM err404 runDB (isBookOwner bookId username) >>= \o -> if o then f u else throwM err403 -putBookContentHandler :: AuthResult SafeUser -> BookID -> ByteString -> AppM NoContent -putBookContentHandler auth bookId content = requireBookOwner auth bookId $ \SafeUser{username} -> do +putBookContentHandler :: AuthResult SafeUser -> BookID -> FileContent -> AppM NoContent +putBookContentHandler auth bookId fc = requireBookOwner auth bookId $ \SafeUser{username} -> do + let content = getFileContent fc key <- HashDigest . convert <$> DS.put content runDB (setContent bookId username key) return NoContent diff --git a/backend/src/API/Catalogue.hs b/backend/src/API/Catalogue.hs index cbace40..13563fa 100644 --- a/backend/src/API/Catalogue.hs +++ b/backend/src/API/Catalogue.hs @@ -24,8 +24,10 @@ import qualified Database.Channel as Channel import GHC.TypeLits import Servant hiding (contentType) import Servant.Auth as SA +import qualified Servant.Docs as Docs import Servant.XML import Server.Auth +import System.IO.Unsafe (unsafePerformIO) import Types -- This is my first try on going to versioned apis, things might change @@ -40,7 +42,7 @@ newtype Rel = Rel { unRel :: Text } deriving (IsString, Show) data Pagination = Pagination { previous :: Maybe Rel , next :: Maybe Rel } - deriving (Show) + deriving (Show, Generic) newtype SubSection = SubSection Rel deriving (Show) newtype Acquisition = Acquisition Rel deriving (Show) @@ -64,6 +66,20 @@ deriving instance Show (Entry 1) deriving instance Generic (Catalog 1) deriving instance Generic (Entry 1) +instance Docs.ToSample (Entry 1) where + toSamples _ = [("Entry", EntryV1 "title" "identifier" docsTime "content" (Left (SubSection (Rel "sub"))))] +instance Docs.ToSample UTCTime where + toSamples _ = [("time", docsTime)] +instance Docs.ToSample Rel where + toSamples _ = [("Relative link", Rel "next")] +instance Docs.ToSample Pagination +instance Docs.ToSample (Catalog 1) -- where + -- toSamples _ = [("catalog", CatalogV1 docsTime (Rel "prev") (Rel "next") (Pagination (Just "previous") (Just "next")) [])] + +docsTime :: UTCTime +docsTime = unsafePerformIO getCurrentTime + + instance ToNode SubSection where toNode (SubSection rel) = [xml||] diff --git a/backend/src/API/Channels.hs b/backend/src/API/Channels.hs index 14388ea..38de049 100644 --- a/backend/src/API/Channels.hs +++ b/backend/src/API/Channels.hs @@ -1,41 +1,47 @@ -{-# Language DataKinds #-} -{-# Language TypeFamilies #-} -{-# Language TypeOperators #-} -{-# Language NoImplicitPrelude #-} -{-# Language MultiParamTypeClasses #-} -{-# Language OverloadedStrings #-} -{-# Language TemplateHaskell #-} -{-# Language QuasiQuotes #-} -{-# Language RecordWildCards #-} -{-# Language DeriveGeneric #-} -{-# Language FlexibleInstances #-} -{-# Language TypeApplications #-} -{-# Language DataKinds #-} -{-# Language DuplicateRecordFields #-} -{-# Language NamedFieldPuns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module API.Channels (API, handler, JsonChannel(..)) where -import ClassyPrelude -import Control.Lens -import Control.Monad.Catch (throwM, MonadThrow) -import Control.Monad.Logger -import Data.Aeson -import Data.Generics.Product -import Database -import Database.Channel -import Servant -import Servant.Auth as SA -import Server.Auth -import Types +import ClassyPrelude +import Control.Lens +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Logger +import Data.Aeson +import Data.Generics.Product +import Database +import Database.Channel +import Servant +import Servant.Auth as SA +import qualified Servant.Docs as Docs +import Server.Auth +import Types -data JsonChannel = JsonChannel { channel :: Text +data JsonChannel = JsonChannel { channel :: Text , visibility :: Visibility } deriving (Show, Generic) data UpdateChannel = UpdateChannel { identifier :: ChannelID - , channel :: Text + , channel :: Text , visibility :: Visibility } deriving (Show, Generic) +instance Docs.ToSample JsonChannel where + toSamples _ = [("Channel", JsonChannel "channel" Private)] + +instance Docs.ToSample UpdateChannel where + toSamples _ = [("Channel", UpdateChannel 13 "channel" Private)] + instance ToJSON JsonChannel instance FromJSON JsonChannel instance ToJSON UpdateChannel @@ -43,6 +49,9 @@ instance FromJSON UpdateChannel type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI +instance Docs.ToCapture (Capture "channel_id" ChannelID) where + toCapture _ = Docs.DocCapture "channel_id" "The channel id" + type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] UpdateChannel :<|> "channels" :> Capture "channel_id" ChannelID :> ReqBody '[JSON] UpdateChannel :> Put '[JSON] UpdateChannel :<|> "channels" :> Get '[JSON] [JsonChannel] diff --git a/backend/src/API/Users.hs b/backend/src/API/Users.hs index 05962b9..8bddd5a 100644 --- a/backend/src/API/Users.hs +++ b/backend/src/API/Users.hs @@ -7,18 +7,19 @@ {-# Language TypeApplications #-} module API.Users where -import ClassyPrelude -import Control.Monad.Catch (throwM, MonadThrow) -import Data.Aeson -import Database (runDB) -import Database.Schema -import Database.User -import Servant -import Servant.Auth as SA -import Servant.Auth.Server as SAS -import Server.Auth -import Types -import Web.FormUrlEncoded +import ClassyPrelude +import Control.Monad.Catch (throwM, MonadThrow) +import Data.Aeson +import Database (runDB) +import Database.Schema +import Database.User +import Servant +import Servant.Auth as SA +import Servant.Auth.Server as SAS +import qualified Servant.Docs as Docs +import Server.Auth +import Types +import Web.FormUrlEncoded data RegisterForm = RegisterForm { username :: Username @@ -27,12 +28,17 @@ data RegisterForm = RegisterForm { username :: Username , passwordAgain :: PlainPassword } deriving (Generic, Show) +instance Docs.ToSample RegisterForm + data LoginStatus = LoginStatus ( Maybe SafeUser ) deriving Generic data RegisterStatus = RegisterStatus deriving Generic +instance Docs.ToSample RegisterStatus + instance ToJSON LoginStatus instance FromJSON LoginStatus +instance Docs.ToSample LoginStatus instance FromJSON RegisterForm instance ToJSON RegisterForm diff --git a/backend/src/Database/Schema.hs b/backend/src/Database/Schema.hs index e08b215..8e3fdae 100644 --- a/backend/src/Database/Schema.hs +++ b/backend/src/Database/Schema.hs @@ -1,80 +1,89 @@ -{-# Language NoImplicitPrelude #-} -{-# Language DeriveGeneric #-} -{-# Language OverloadedStrings #-} -{-# Language DuplicateRecordFields #-} -{-# Language GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Database.Schema where -import ClassyPrelude -import Database.Selda.Generic -import Database.Selda -import Database.Selda.Backend - -import Data.Aeson -import Web.HttpApiData +import ClassyPrelude +import Data.Aeson +import Database.Selda +import Database.Selda.Backend +import Database.Selda.Generic +import qualified Servant.Docs as Docs +import Web.HttpApiData -- | User type newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic) newtype HashedPassword = HashedPassword {unHashed :: ByteString} data NoPassword = NoPassword -newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Generic, Eq) +newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Generic, Eq, IsString) -newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic) +newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic, IsString) + +instance Docs.ToSample Username where + toSamples _ = [("Username", Username "user123")] + +instance Docs.ToSample Email where + toSamples _ = [("Email", Email "first.last@example.com")] + +instance Docs.ToSample PlainPassword where + toSamples _ = [("Password", PlainPassword "password123")] instance SqlType HashedPassword where mkLit = LCustom . LBlob . unHashed fromSql (SqlBlob x) = HashedPassword x - fromSql _ = error "fromSql: Bad hash" + fromSql _ = error "fromSql: Bad hash" defaultValue = mkLit (HashedPassword "") -- Makes no sense instance SqlType Email where mkLit = LCustom . LText . unEmail fromSql (SqlString x) = Email x - fromSql _ = error "fromSql: Bad email" + fromSql _ = error "fromSql: Bad email" defaultValue = mkLit (Email "") instance SqlType Username where mkLit = LCustom . LText . unUsername fromSql (SqlString x) = Username x - fromSql _ = error "fromSql: Bad username" + fromSql _ = error "fromSql: Bad username" defaultValue = mkLit (Username "") newtype UserID = UserID {unUserID :: Int} deriving (Show) -newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData, Generic) +newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData, Generic, Num) -newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, Eq, Generic) +newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, Eq, Generic, Num) newtype TagID = TagID {unTagID :: Int} deriving (Show) instance SqlType UserID where mkLit = LCustom . LInt . unUserID fromSql (SqlInt x) = UserID x - fromSql _ = error "fromSql: Bad userid" + fromSql _ = error "fromSql: Bad userid" sqlType _ = TRowID defaultValue = mkLit (UserID (-1)) instance SqlType BookID where mkLit = LCustom . LInt . unBookID fromSql (SqlInt x) = BookID x - fromSql _ = error "fromSql: Bad bookid" + fromSql _ = error "fromSql: Bad bookid" defaultValue = mkLit (BookID (-1)) instance SqlType ChannelID where mkLit = LCustom . LInt . unChannelID fromSql (SqlInt x) = ChannelID x - fromSql _ = error "fromSql: Bad channelid" + fromSql _ = error "fromSql: Bad channelid" defaultValue = mkLit (ChannelID (-1)) instance SqlType TagID where mkLit = LCustom . LInt . unTagID fromSql (SqlInt x) = TagID x - fromSql _ = error "fromSql: Bad tagid" + fromSql _ = error "fromSql: Bad tagid" defaultValue = mkLit (TagID (-1)) data User pass = User { identifier :: UserID - , email :: Email - , username :: Username - , role :: Role - , password :: pass } + , email :: Email + , username :: Username + , role :: Role + , password :: pass } deriving (Show, Generic) data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic, Eq) @@ -98,18 +107,18 @@ users = genTable "users" [ (email :: User HashedPassword -> Email) :- uniqueGen -- | Book type newtype HashDigest = HashDigest { unHex :: ByteString } deriving Show -- XXX: Add an identifier for the book -data Book = Book { identifier :: BookID +data Book = Book { identifier :: BookID , contentHash :: Maybe HashDigest , contentType :: Text - , title :: Text + , title :: Text , description :: Maybe Text - , owner :: UserID } + , owner :: UserID } deriving (Show, Generic) instance SqlType HashDigest where mkLit = LCustom . LBlob . unHex fromSql (SqlBlob x) = HashDigest x - fromSql _ = error "fromSql: Not a valid hash digest" + fromSql _ = error "fromSql: Not a valid hash digest" defaultValue = mkLit (HashDigest "") -- Doesn't really make sense books :: GenTable Book @@ -120,8 +129,8 @@ books = genTable "books" [ (identifier :: Book -> BookID) :- autoPrimaryGen -- | Categorizing books data Tag = Tag { identifier :: TagID - , tag :: Text - , owner :: UserID } + , tag :: Text + , owner :: UserID } deriving (Show, Generic) data Visibility = Public | Private | Followers @@ -137,8 +146,8 @@ instance SqlType Visibility where defaultValue = mkLit Private data Channel = Channel { identifier :: ChannelID - , channel :: Text - , owner :: UserID + , channel :: Text + , owner :: UserID , visibility :: Visibility } deriving (Show, Generic) @@ -154,12 +163,12 @@ channels = genTable "channels" [ (identifier :: Channel -> ChannelID) :- autoPri where i :*: _ = selectors (gen users) -data BookTag = BookTag { tag :: TagID +data BookTag = BookTag { tag :: TagID , book :: BookID } deriving (Show, Generic) data BookChannel = BookChannel { channel :: ChannelID - , book :: BookID } + , book :: BookID } deriving (Show, Generic) bookTags :: GenTable BookTag diff --git a/backend/src/Server.hs b/backend/src/Server.hs index 866f5d3..909371b 100644 --- a/backend/src/Server.hs +++ b/backend/src/Server.hs @@ -1,37 +1,45 @@ -{-# Language DataKinds #-} -{-# Language TypeFamilies #-} -{-# Language TypeOperators #-} -{-# Language NoImplicitPrelude #-} -{-# Language MultiParamTypeClasses #-} -{-# Language OverloadedStrings #-} -{-# Language TemplateHaskell #-} -{-# Language QuasiQuotes #-} -{-# Language RecordWildCards #-} -{-# Language DeriveGeneric #-} -{-# Language FlexibleInstances #-} -{-# Language TypeApplications #-} -{-# Language ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Server where -import qualified API as API -import Server.Auth (authCheck) -import Servant -import Types -import ClassyPrelude hiding (Handler) -import Control.Monad.Logger -import Control.Monad.Except -import Servant.Auth.Server as SAS -import Control.Lens -import Data.Generics.Product -import Server.Auth (SafeUser) +import qualified API as API +import ClassyPrelude hiding (Handler) +import Control.Lens +import Control.Monad.Except +import Control.Monad.Logger +import Data.Generics.Product +import Servant +import Servant.Auth.Docs () +import Servant.Auth.Server as SAS +import qualified Servant.Docs as Docs +import Servant.HTML.Lucid (HTML) +import Server.Auth (SafeUser) +import Server.Auth (authCheck) +import Types -type API = API.API :<|> "static" :> Raw +type API = API.API + :<|> "help" :> Get '[PlainText, HTML] String + :<|> "static" :> Raw type Ctx = '[BasicAuthData -> IO (AuthResult SafeUser), CookieSettings, JWTSettings] server :: App -> Application -server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDirectoryFileServer "static") +server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDocs :<|> serveDirectoryFileServer "static") where + apiDocs :: Docs.API + apiDocs = Docs.docs (Proxy @API.API) + serveDocs = pure $ Docs.markdown apiDocs myKey = view (field @"jwk") app jwtCfg = defaultJWTSettings myKey authCfg = authCheck app diff --git a/backend/src/Server/Auth.hs b/backend/src/Server/Auth.hs index 997755a..d70f270 100644 --- a/backend/src/Server/Auth.hs +++ b/backend/src/Server/Auth.hs @@ -1,11 +1,11 @@ -{-# Language DataKinds #-} -{-# Language TypeFamilies #-} -{-# Language OverloadedStrings #-} -{-# Language NoImplicitPrelude #-} -{-# Language TypeOperators #-} -{-# Language DuplicateRecordFields #-} -{-# Language TypeApplications #-} -{-# Language TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Server.Auth ( SafeUser(..) , authCheck @@ -13,29 +13,33 @@ module Server.Auth , requireLoggedIn) where -import ClassyPrelude -import Control.Lens (view) -import Control.Monad.Logger -import Control.Monad.Catch (throwM, MonadThrow) -import Data.Aeson -import Data.Generics.Product -import Database -import Database.Schema -import Database.User -import Servant (err401) -import Servant.Auth.Server as SAS -import Types +import ClassyPrelude +import Control.Lens (view) +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Logger +import Data.Aeson +import Data.Generics.Product +import Database +import Database.Schema +import Database.User +import Servant (err401) +import Servant.Auth.Server as SAS +import qualified Servant.Docs as Docs +import Types -- generic-lens can convert similar types to this -- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone -- can open the jwt token and view what's inside, you just can't modify it. -- -- Is it a problem that a human readable username and email are visible? -data SafeUser = SafeUser { email :: Email +data SafeUser = SafeUser { email :: Email , username :: Username - , role :: Role } + , role :: Role } deriving (Show, Generic) +instance Docs.ToSample SafeUser where + toSamples _ = [("User", SafeUser "user@example.com" "user" UserRole )] + instance ToJSON SafeUser where instance FromJSON SafeUser where instance ToJWT SafeUser where diff --git a/migrations/V1.2__unique_tags.sql b/migrations/V1.2__unique_tags.sql new file mode 100644 index 0000000..1bc9c32 --- /dev/null +++ b/migrations/V1.2__unique_tags.sql @@ -0,0 +1 @@ +create unique index tag_owner on tags (tag, owner);