Listing books

src/API.hs

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

src/API/Books.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.Books where
+
+import Servant hiding (contentType)
+import Types
+import ClassyPrelude
+import Server.Auth
+import Servant.Auth as SA
+import Data.Aeson
+import API.Channels (JsonChannel(..))
+import Database.Book
+import Database.Channel
+import Database
+import Control.Lens
+import Data.Generics.Product
+
+data JsonBook = JsonBook { contentType :: Text
+                         , title :: Maybe Text
+                         , description :: Maybe Text
+                         , channels :: [JsonChannel] }
+              deriving (Generic, Show)
+
+instance ToJSON JsonBook
+instance FromJSON JsonBook
+
+type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
+
+type BaseAPI = "books" :> Get '[JSON] [JsonBook]
+
+handler :: ServerT API AppM
+handler user = listBooksHandler user
+
+listBooksHandler :: AuthResult SafeUser -> AppM [JsonBook]
+listBooksHandler = requireLoggedIn $ \user -> do
+  runDB (usersBooks (view (field @"username") user) >>= mapM augment)
+    where
+      augment Book{..} = do
+        channels <- fmap (\Channel{..} -> JsonChannel{..}) <$> booksChannels contentHash
+        pure JsonBook{..}

src/API/Channels.hs

@@ -11,7 +11,7 @@
 {-# Language FlexibleInstances #-}
 {-# Language TypeApplications #-}
 {-# Language DataKinds #-}
-module API.Channels (API, handler) where
+module API.Channels (API, handler, JsonChannel(..)) where
 
 import Servant
 import Types

src/Database/Book.hs

@@ -0,0 +1,21 @@
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+module Database.Book (usersBooks, Book(..)) where
+
+import ClassyPrelude
+import Database.Schema
+import Database
+import Database.Selda
+
+usersBooks :: (MonadMask m, MonadIO m) => Username -> SeldaT m [Book]
+usersBooks username = fromRels <$> query q
+  where
+    q = do
+      userId :*: _ :*: username' :*: _ <- select (gen users)
+      userId' :*: bookHash' <- select (gen userBooks)
+      book@(bookHash :*: _) <- select (gen books)
+      restrict (bookHash .== bookHash')
+      restrict (username' .== literal username)
+      restrict (userId .== userId')
+      return book
+

src/Database/Channel.hs

@@ -3,6 +3,7 @@
 module Database.Channel
   ( userChannels
   , insertChannel
+  , booksChannels
   , Channel(..) )
   where
 
@@ -32,3 +33,13 @@ insertChannel username channel = do
       userId :*: _ :*: user :*: _ <- select (gen users)
       restrict (user .== literal username)
       return userId
+
+booksChannels :: (MonadMask m, MonadIO m) => HashDigest -> SeldaT m [Channel]
+booksChannels contentHash = fromRels <$> query q
+  where
+    q = do
+      channelId :*: contentHash' <- select (gen bookChannels)
+      ch@(channelId' :*: _) <- select (gen channels)
+      restrict (channelId .== channelId')
+      restrict (contentHash' .== literal contentHash)
+      return ch

src/Database/Schema.hs

@@ -83,15 +83,15 @@ instance SqlType HashDigest where
 books :: GenTable Book
 books = genTable "books" [ contentHash :- primaryGen ]
 
-data UserBook = UserBook { email :: Text
+data UserBook = UserBook { user :: RowID
                          , book :: HashDigest }
               deriving (Generic, Show)
 
 userBooks :: GenTable UserBook
-userBooks = genTable "user_book" [ (email :: UserBook -> Text) :- fkGen (gen users) userEmail
+userBooks = genTable "user_book" [ (user :: UserBook -> RowID) :- fkGen (gen users) userId
                                  , (book :: UserBook -> HashDigest) :- fkGen (gen books) bookHash ]
   where
-    _ :*: userEmail :*: _ = selectors (gen users)
+    userId :*: _ = selectors (gen users)
     bookHash :*: _ = selectors (gen books)
 
 -- | Categorizing books