From 46c728c3c8badcb5b38a9554e60620f6e8a3877d Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Sun, 5 Aug 2018 23:42:37 +0300
Subject: [PATCH] Listing books

---
 src/API.hs              |  3 +++
 src/API/Books.hs        | 51 +++++++++++++++++++++++++++++++++++++++++
 src/API/Channels.hs     |  2 +-
 src/Database/Book.hs    | 21 +++++++++++++++++
 src/Database/Channel.hs | 11 +++++++++
 src/Database/Schema.hs  |  6 ++---
 6 files changed, 90 insertions(+), 4 deletions(-)
 create mode 100644 src/API/Books.hs
 create mode 100644 src/Database/Book.hs

diff --git a/src/API.hs b/src/API.hs
index 32651a2..e1bdc83 100644
--- a/src/API.hs
+++ b/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
diff --git a/src/API/Books.hs b/src/API/Books.hs
new file mode 100644
index 0000000..6a2a424
--- /dev/null
+++ b/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{..}
diff --git a/src/API/Channels.hs b/src/API/Channels.hs
index 335c15d..2e6c0ed 100644
--- a/src/API/Channels.hs
+++ b/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
diff --git a/src/Database/Book.hs b/src/Database/Book.hs
new file mode 100644
index 0000000..251d44e
--- /dev/null
+++ b/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
+
diff --git a/src/Database/Channel.hs b/src/Database/Channel.hs
index 9d482e0..64cd21f 100644
--- a/src/Database/Channel.hs
+++ b/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
diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs
index 5a47e94..7fe61bc 100644
--- a/src/Database/Schema.hs
+++ b/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