Channels API

ebook-manager.cabal

@@ -19,9 +19,11 @@ executable ebook-manager
   main-is:             Main.hs
   other-modules:       Devel.Main
                      , API
+                     , API.Channels
                      , API.Users
                      , Configuration
                      , Database
+                     , Database.Channel
                      , Database.Schema
                      , Database.User
                      , Server

src/API.hs

@@ -19,14 +19,18 @@ import Types
 import View
 
 import qualified API.Users as Users
+import qualified API.Channels as Channels
 
 data Index = Index
 
 type API = Get '[HTML] (AppView Index)
       :<|> Users.API
+      :<|> Channels.API
 
 handler :: ServerT API AppM
-handler = indexHandler :<|> Users.handler
+handler = indexHandler
+    :<|> Users.handler
+    :<|> Channels.handler
 
 instance ToHtml Index where
   toHtml _ = do

src/API/Channels.hs

@@ -0,0 +1,51 @@
+{-# 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 #-}
+module API.Channels (API, handler) where
+
+import Servant
+import Types
+import ClassyPrelude
+import Server.Auth
+import Servant.Auth as SA
+import Control.Monad.Logger
+import Database
+import Database.Channel
+import Data.Aeson
+import Control.Lens
+import Data.Generics.Product
+
+data JsonChannel = JsonChannel { channel :: Text } deriving (Show, Generic)
+
+instance ToJSON JsonChannel
+instance FromJSON JsonChannel
+
+type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI
+
+type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Put '[JSON] JsonChannel
+          :<|> "channels" :> Get '[JSON] [JsonChannel]
+
+handler :: ServerT API AppM
+handler user = newChannelHandler user :<|> listChannelsHandler user
+
+listChannelsHandler :: AuthResult SafeUser -> AppM [JsonChannel]
+listChannelsHandler = requireLoggedIn $ \user ->
+  -- I could use the super thing from generic-lens, but then I would need to
+  -- use the 'channel' accessor somehow or export it
+  fmap (\Channel{..} -> JsonChannel{..}) <$> runDB (userChannels (view (field @"username") user))
+
+newChannelHandler :: AuthResult SafeUser -> JsonChannel -> AppM JsonChannel
+newChannelHandler auth ch@JsonChannel{..} = flip requireLoggedIn auth $ \user -> do
+  $logInfo $ "Creating channel for user " <> pack (show user)
+  runDB (insertChannel (view (field @"username") user) channel)
+  return ch

src/API/Users.hs

@@ -41,7 +41,7 @@ instance FromForm RegisterForm
 instance ToForm RegisterForm
 
 
-type API = Auth '[SA.BasicAuth] SafeUser :> "login" :> Get '[JSON] LoginStatus
+type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> "login" :> Get '[JSON] LoginStatus
       :<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
 
 handler :: ServerT API AppM

src/Database.hs

@@ -9,6 +9,7 @@ module Database
   , select
   , gen
   , fromRel
+  , fromRels
   , toRel
   , SeldaT )
   where
@@ -18,7 +19,7 @@ import Control.Lens (view)
 import Data.Pool (Pool, withResource)
 import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
 import Database.Selda (query, select)
-import Database.Selda.Generic (gen, fromRel, toRel)
+import Database.Selda.Generic (gen, fromRel, fromRels, toRel)
 import ClassyPrelude
 
 type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection))

src/Database/Channel.hs

@@ -0,0 +1,34 @@
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+module Database.Channel
+  ( userChannels
+  , insertChannel
+  , Channel(..) )
+  where
+
+import ClassyPrelude
+import Database.Schema
+import Database
+import Database.Selda
+
+userChannels :: (MonadMask m, MonadIO m) => Username -> SeldaT m [Channel]
+userChannels username = fromRels <$> query q
+  where
+    q = do
+      userId :*: _ :*: username' :*: _ <- select (gen users)
+      channel@(_ :*: _ :*: owner) <- select (gen channels)
+      restrict (owner .== userId)
+      restrict (username' .== literal username)
+      return channel
+
+insertChannel :: (MonadMask m, MonadIO m) => Username -> Text -> SeldaT m ()
+insertChannel username channel = do
+  mUserId <- listToMaybe <$> getUser
+  void $ forM mUserId $ \userId ->
+    insertUnless (gen channels) (doesNotExist userId) [ def :*: channel :*: userId ]
+  where
+    doesNotExist userId (_ :*: channel' :*: userId') = channel' .== literal channel .&& userId' .== literal userId
+    getUser = query $ do
+      userId :*: _ :*: user :*: _ <- select (gen users)
+      restrict (user .== literal username)
+      return userId

src/Database/Schema.hs

@@ -112,8 +112,8 @@ tags = genTable "tags" [ (identifier :: Tag -> RowID) :- autoPrimaryGen
     i :*: _ = selectors (gen users)
 
 channels :: GenTable Channel
-channels = genTable "tags" [ (identifier :: Channel -> RowID) :- autoPrimaryGen
-                           , (owner :: Channel -> RowID) :- fkGen (gen users) i ]
+channels = genTable "channels" [ (identifier :: Channel -> RowID) :- autoPrimaryGen
+                               , (owner :: Channel -> RowID) :- fkGen (gen users) i ]
   where
     i :*: _ = selectors (gen users)
 

src/Server.hs

@@ -19,7 +19,7 @@ import Types
 import ClassyPrelude hiding (Handler)
 import Control.Monad.Logger
 import Control.Monad.Except
-import Servant.Auth.Server
+import Servant.Auth.Server as SAS
 import Control.Lens
 import Data.Generics.Product
 
@@ -32,7 +32,8 @@ server app = serveWithContext api cfg (enter server' API.handler :<|> serveDirec
     myKey = view (field @"jwk") app
     jwtCfg = defaultJWTSettings myKey
     authCfg = authCheck app
-    cfg = jwtCfg :. defaultCookieSettings :. authCfg :. EmptyContext
+    cookieSettings = SAS.defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
+    cfg = jwtCfg :. cookieSettings :. authCfg :. EmptyContext
     server' :: AppM :~> Servant.Handler
     server' = NT (Handler . ExceptT . try . (`runReaderT` app) . (runFileLoggingT "logs/server.log"))
     api :: Proxy API

src/Server/Auth.hs

@@ -5,7 +5,13 @@
 {-# Language TypeOperators #-}
 {-# Language DuplicateRecordFields #-}
 {-# Language TypeApplications #-}
-module Server.Auth where
+{-# Language TemplateHaskell #-}
+module Server.Auth
+  ( SafeUser(..)
+  , authCheck
+  , AuthResult(..)
+  , requireLoggedIn)
+  where
 
 import ClassyPrelude
 import Servant.Auth.Server as SAS
@@ -16,6 +22,8 @@ import Database
 import Types
 import Control.Lens (view)
 import Data.Generics.Product
+import Servant (err401)
+import Control.Monad.Logger
 
 -- generic-lens can convert similar types to this
 -- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone
@@ -44,3 +52,7 @@ authCheck app (BasicAuthData username password) = flip runReaderT app $
     username' = Username $ decodeUtf8 username
     password' = PlainPassword $ decodeUtf8 password
     authenticated = SAS.Authenticated . view (super @SafeUser)
+
+requireLoggedIn :: (MonadLogger m, MonadThrow m, Monad m) => (SafeUser -> m a) -> AuthResult SafeUser -> m a
+requireLoggedIn f (Authenticated user) = f user
+requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401

src/View.hs

@@ -8,7 +8,6 @@ module View
 
 import ClassyPrelude
 import Server.Auth
-import Servant.Auth.Server
 import Lucid (HtmlT, ToHtml(..))
 import Lucid.Html5 as H