MasseR
/
ebook-manager
1
0
Fork 0
Code Issues 9 Pull Requests Releases Wiki Activity

Docs support

This commit is contained in:
Mats Rauhala 2018-11-12 21:32:42 +02:00
parent 7928aa1cb6
commit 5727ea5574
10 changed files with 235 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
backend/backend.cabal
View File

@ -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

6
backend/src/API.hs
View File

@ -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

88
backend/src/API/Books.hs
View File

@ -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

18
backend/src/API/Catalogue.hs
View File

@ -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|<link type="application/atom+xml;profile=opds-catalog;kind=acquisition" rel="subsection" href="#{unRel rel}">|]

67
backend/src/API/Channels.hs
View File

@ -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]

30
backend/src/API/Users.hs
View File

@ -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

83
backend/src/Database/Schema.hs
View File

@ -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

60
backend/src/Server.hs
View File

@ -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

48
backend/src/Server/Auth.hs
View File

@ -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

1
migrations/V1.2__unique_tags.sql Normal file
View File

@ -0,0 +1 @@
create unique index tag_owner on tags (tag, owner);