Compare commits
	
		
			8 Commits
		
	
	
		
			ce338f067b
			...
			sandbox/Ma
		
	
	| Author | SHA1 | Date | |
|---|---|---|---|
| dc32120ca8 | |||
| a580138e0d | |||
| 786927ccbd | |||
| f5f6c9ced9 | |||
| fdbd24a4bf | |||
| 6865af361d | |||
| d792cb2a81 | |||
| cd086165db | 
							
								
								
									
										5
									
								
								backend/ChangeLog.md
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										5
									
								
								backend/ChangeLog.md
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1,5 @@
 | 
			
		||||
# Revision history for backend
 | 
			
		||||
 | 
			
		||||
## 0.1.0.0 -- YYYY-mm-dd
 | 
			
		||||
 | 
			
		||||
* First version. Released on an unsuspecting world.
 | 
			
		||||
							
								
								
									
										30
									
								
								backend/LICENSE
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										30
									
								
								backend/LICENSE
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1,30 @@
 | 
			
		||||
Copyright (c) 2018, Mats Rauhala
 | 
			
		||||
 | 
			
		||||
All rights reserved.
 | 
			
		||||
 | 
			
		||||
Redistribution and use in source and binary forms, with or without
 | 
			
		||||
modification, are permitted provided that the following conditions are met:
 | 
			
		||||
 | 
			
		||||
    * Redistributions of source code must retain the above copyright
 | 
			
		||||
      notice, this list of conditions and the following disclaimer.
 | 
			
		||||
 | 
			
		||||
    * Redistributions in binary form must reproduce the above
 | 
			
		||||
      copyright notice, this list of conditions and the following
 | 
			
		||||
      disclaimer in the documentation and/or other materials provided
 | 
			
		||||
      with the distribution.
 | 
			
		||||
 | 
			
		||||
    * Neither the name of Mats Rauhala nor the names of other
 | 
			
		||||
      contributors may be used to endorse or promote products derived
 | 
			
		||||
      from this software without specific prior written permission.
 | 
			
		||||
 | 
			
		||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 | 
			
		||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 | 
			
		||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 | 
			
		||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 | 
			
		||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 | 
			
		||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 | 
			
		||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 | 
			
		||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 | 
			
		||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 | 
			
		||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 | 
			
		||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 | 
			
		||||
							
								
								
									
										2
									
								
								backend/Setup.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										2
									
								
								backend/Setup.hs
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1,2 @@
 | 
			
		||||
import Distribution.Simple
 | 
			
		||||
main = defaultMain
 | 
			
		||||
@@ -1,7 +1,7 @@
 | 
			
		||||
-- Initial ebook-manager.cabal generated by cabal init.  For further
 | 
			
		||||
-- Initial backend.cabal generated by cabal init.  For further
 | 
			
		||||
-- documentation, see http://haskell.org/cabal/users-guide/
 | 
			
		||||
 | 
			
		||||
name:                ebook-manager
 | 
			
		||||
name:                backend
 | 
			
		||||
version:             0.1.0.0
 | 
			
		||||
-- synopsis:
 | 
			
		||||
-- description:
 | 
			
		||||
@@ -15,30 +15,29 @@ build-type:          Simple
 | 
			
		||||
extra-source-files:  ChangeLog.md
 | 
			
		||||
cabal-version:       >=1.10
 | 
			
		||||
 | 
			
		||||
executable ebook-manager
 | 
			
		||||
executable backend
 | 
			
		||||
  main-is:             Main.hs
 | 
			
		||||
  other-modules:       Devel.Main
 | 
			
		||||
                     , API
 | 
			
		||||
                     , API.Books
 | 
			
		||||
                     , API.Catalogue
 | 
			
		||||
                     , API.Channels
 | 
			
		||||
                     , API.Users
 | 
			
		||||
                     , Configuration
 | 
			
		||||
                     , Data.Versioned
 | 
			
		||||
                     , Database
 | 
			
		||||
                     , Database.Book
 | 
			
		||||
                     , Database.Channel
 | 
			
		||||
                     , Database.Tag
 | 
			
		||||
                     , Database.Schema
 | 
			
		||||
                     , Database.Tag
 | 
			
		||||
                     , Database.User
 | 
			
		||||
                     , Datastore
 | 
			
		||||
                     , Servant.XML
 | 
			
		||||
                     , Server
 | 
			
		||||
                     , Server.API
 | 
			
		||||
                     , Server.API.Books
 | 
			
		||||
                     , Server.API.Catalogue
 | 
			
		||||
                     , Server.API.Channels
 | 
			
		||||
                     , Server.API.Users
 | 
			
		||||
                     , Server.Auth
 | 
			
		||||
                     , Types
 | 
			
		||||
                     , View
 | 
			
		||||
  -- other-extensions:
 | 
			
		||||
  build-depends:       base >=4.10 && <4.11
 | 
			
		||||
                     , common
 | 
			
		||||
                     , aeson
 | 
			
		||||
                     , asn1-data
 | 
			
		||||
                     , asn1-types
 | 
			
		||||
@@ -80,8 +79,8 @@ executable ebook-manager
 | 
			
		||||
                     , xml-conduit
 | 
			
		||||
                     , xml-hamlet
 | 
			
		||||
  hs-source-dirs:      src
 | 
			
		||||
  default-language:    Haskell2010
 | 
			
		||||
  default-extensions:  DeriveGeneric
 | 
			
		||||
                     , NoImplicitPrelude
 | 
			
		||||
                     , OverloadedStrings
 | 
			
		||||
                     , RecordWildCards
 | 
			
		||||
  default-language:    Haskell2010
 | 
			
		||||
@@ -51,7 +51,7 @@ getBook identifier owner = listToMaybe . fromRels <$> query q
 | 
			
		||||
      return book
 | 
			
		||||
 | 
			
		||||
data InsertBook = InsertBook { contentType :: Text
 | 
			
		||||
                             , title :: Maybe Text
 | 
			
		||||
                             , title :: Text
 | 
			
		||||
                             , description :: Maybe Text
 | 
			
		||||
                             , owner :: Username }
 | 
			
		||||
 | 
			
		||||
@@ -68,7 +68,7 @@ insertBook InsertBook{..} = do
 | 
			
		||||
 | 
			
		||||
data UpdateBook = UpdateBook { identifier :: BookID
 | 
			
		||||
                             , contentType :: Text
 | 
			
		||||
                             , title :: Maybe Text
 | 
			
		||||
                             , title :: Text
 | 
			
		||||
                             , description :: Maybe Text
 | 
			
		||||
                             , owner :: Username
 | 
			
		||||
                             , tags :: [Text]
 | 
			
		||||
@@ -11,8 +11,9 @@ module Database.Channel
 | 
			
		||||
  , Visibility(..)
 | 
			
		||||
  , clearChannels
 | 
			
		||||
  , booksChannels
 | 
			
		||||
  , channelBooks
 | 
			
		||||
  , Channel(..)
 | 
			
		||||
  , ChannelID )
 | 
			
		||||
  , ChannelID(..) )
 | 
			
		||||
  where
 | 
			
		||||
 | 
			
		||||
import ClassyPrelude
 | 
			
		||||
@@ -80,6 +81,19 @@ insertChannel username channel visibility = runMaybeT $ do
 | 
			
		||||
      restrict (user .== literal username)
 | 
			
		||||
      return userId
 | 
			
		||||
 | 
			
		||||
channelBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> ChannelID -> m [Book]
 | 
			
		||||
channelBooks username identifier = fromRels <$> query q
 | 
			
		||||
  where
 | 
			
		||||
    q = do
 | 
			
		||||
      channelId :*: bookId' <- select (gen bookChannels)
 | 
			
		||||
      channelId' :*: _ :*: owner :*: _ <- select (gen channels)
 | 
			
		||||
      userId :*: _ :*: username' :*: _ <- select (gen users)
 | 
			
		||||
      book@(bookId :*: _) <- select (gen books)
 | 
			
		||||
      restrict (username' .== literal username .&& owner .== userId)
 | 
			
		||||
      restrict (channelId .== literal identifier .&& channelId .== channelId')
 | 
			
		||||
      restrict (bookId .== bookId')
 | 
			
		||||
      return book
 | 
			
		||||
 | 
			
		||||
booksChannels :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m [Channel]
 | 
			
		||||
booksChannels bookId = fromRels <$> query q
 | 
			
		||||
  where
 | 
			
		||||
@@ -18,9 +18,6 @@ newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToH
 | 
			
		||||
newtype HashedPassword = HashedPassword {unHashed :: ByteString}
 | 
			
		||||
data NoPassword = NoPassword
 | 
			
		||||
 | 
			
		||||
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
 | 
			
		||||
 | 
			
		||||
newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
 | 
			
		||||
 | 
			
		||||
instance SqlType HashedPassword where
 | 
			
		||||
  mkLit = LCustom . LBlob . unHashed
 | 
			
		||||
@@ -42,7 +39,7 @@ instance SqlType Username where
 | 
			
		||||
 | 
			
		||||
newtype UserID = UserID {unUserID :: Int} deriving (Show)
 | 
			
		||||
 | 
			
		||||
newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord)
 | 
			
		||||
newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData)
 | 
			
		||||
 | 
			
		||||
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON)
 | 
			
		||||
 | 
			
		||||
@@ -101,7 +98,7 @@ newtype HashDigest = HashDigest { unHex :: ByteString } deriving Show
 | 
			
		||||
data Book = Book { identifier :: BookID
 | 
			
		||||
                 , contentHash :: Maybe HashDigest
 | 
			
		||||
                 , contentType :: Text
 | 
			
		||||
                 , title :: Maybe Text
 | 
			
		||||
                 , title :: Text
 | 
			
		||||
                 , description :: Maybe Text
 | 
			
		||||
                 , owner :: UserID }
 | 
			
		||||
          deriving (Show, Generic)
 | 
			
		||||
@@ -37,7 +37,7 @@ update = do
 | 
			
		||||
 | 
			
		||||
develMain :: IO ()
 | 
			
		||||
develMain = do
 | 
			
		||||
  conf <- input auto "./config/devel.dhall"
 | 
			
		||||
  conf <- input auto "../config/devel.dhall"
 | 
			
		||||
  withApp conf $ \app -> do
 | 
			
		||||
    void $ runReaderT (runDB migrate) app
 | 
			
		||||
    defaultMain app
 | 
			
		||||
@@ -1,9 +1,11 @@
 | 
			
		||||
{-# Language OverloadedStrings #-}
 | 
			
		||||
{-# Language FlexibleInstances #-}
 | 
			
		||||
{-# Language MultiParamTypeClasses #-}
 | 
			
		||||
{-# Language TypeApplications #-}
 | 
			
		||||
module Servant.XML
 | 
			
		||||
  ( ToNode(..)
 | 
			
		||||
  , XML
 | 
			
		||||
  , OPDS
 | 
			
		||||
  , Text.Hamlet.XML.xml
 | 
			
		||||
  , iso8601 )
 | 
			
		||||
  where
 | 
			
		||||
@@ -16,14 +18,22 @@ import Network.HTTP.Media.MediaType
 | 
			
		||||
 | 
			
		||||
data XML
 | 
			
		||||
 | 
			
		||||
data OPDS
 | 
			
		||||
 | 
			
		||||
instance (ToNode a) => MimeRender XML a where
 | 
			
		||||
  mimeRender _ a =
 | 
			
		||||
    let [NodeElement root] = toNode a
 | 
			
		||||
    in renderLBS def (Document (Prologue [] Nothing []) root [])
 | 
			
		||||
 | 
			
		||||
instance (ToNode a) => MimeRender OPDS a where
 | 
			
		||||
  mimeRender _ a = mimeRender (Proxy @XML) a
 | 
			
		||||
 | 
			
		||||
instance Accept XML where
 | 
			
		||||
  contentType _ = "application" // "xml" /: ("charset", "utf-8")
 | 
			
		||||
 | 
			
		||||
instance Accept OPDS where
 | 
			
		||||
  contentType _ = "application" // "atom+xml" /: ("charset", "utf-8") /: ("profile", "opds-catalog")
 | 
			
		||||
 | 
			
		||||
iso8601 :: UTCTime -> Text
 | 
			
		||||
iso8601 = pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"
 | 
			
		||||
 | 
			
		||||
@@ -12,7 +12,7 @@
 | 
			
		||||
{-# Language TypeApplications #-}
 | 
			
		||||
module Server where
 | 
			
		||||
 | 
			
		||||
import qualified API as API
 | 
			
		||||
import qualified Server.API as API
 | 
			
		||||
import Server.Auth (authCheck)
 | 
			
		||||
import Servant
 | 
			
		||||
import Types
 | 
			
		||||
@@ -9,7 +9,7 @@
 | 
			
		||||
{-# Language RecordWildCards #-}
 | 
			
		||||
{-# Language DeriveGeneric #-}
 | 
			
		||||
{-# Language FlexibleInstances #-}
 | 
			
		||||
module API (API, handler) where
 | 
			
		||||
module Server.API (API, handler) where
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
import Servant
 | 
			
		||||
@@ -18,17 +18,17 @@ import Types
 | 
			
		||||
 | 
			
		||||
import View
 | 
			
		||||
 | 
			
		||||
import qualified API.Users as Users
 | 
			
		||||
import qualified API.Channels as Channels
 | 
			
		||||
import qualified API.Books as Books
 | 
			
		||||
import qualified API.Catalogue as Catalogue
 | 
			
		||||
import qualified Server.API.Users as Users
 | 
			
		||||
import qualified Server.API.Channels as Channels
 | 
			
		||||
import qualified Server.API.Books as Books
 | 
			
		||||
import qualified Server.API.Catalogue as Catalogue
 | 
			
		||||
 | 
			
		||||
data Index = Index
 | 
			
		||||
 | 
			
		||||
type API = Get '[HTML] (AppView Index)
 | 
			
		||||
      :<|> Users.API
 | 
			
		||||
      :<|> "api" :> Channels.API
 | 
			
		||||
      :<|> "api" :> Books.API
 | 
			
		||||
      :<|> "api" :> "current" :> Channels.API
 | 
			
		||||
      :<|> "api" :> "current" :> Books.API
 | 
			
		||||
      :<|> "api" :> "1" :> Catalogue.VersionedAPI 1
 | 
			
		||||
      :<|> "api" :> "current" :> Catalogue.VersionedAPI 1
 | 
			
		||||
 | 
			
		||||
@@ -13,7 +13,7 @@
 | 
			
		||||
{-# Language TypeApplications #-}
 | 
			
		||||
{-# Language DataKinds #-}
 | 
			
		||||
{-# Language NamedFieldPuns #-}
 | 
			
		||||
module API.Books where
 | 
			
		||||
module Server.API.Books where
 | 
			
		||||
 | 
			
		||||
import Servant hiding (contentType)
 | 
			
		||||
import Types
 | 
			
		||||
@@ -36,14 +36,14 @@ import Crypto.Hash (digestFromByteString)
 | 
			
		||||
 | 
			
		||||
data JsonBook = JsonBook { identifier :: BookID
 | 
			
		||||
                         , contentType :: Text
 | 
			
		||||
                         , title :: Maybe Text
 | 
			
		||||
                         , title :: Text
 | 
			
		||||
                         , description :: Maybe Text
 | 
			
		||||
                         , channels :: [Text]
 | 
			
		||||
                         , tags :: [Text] }
 | 
			
		||||
              deriving (Generic, Show)
 | 
			
		||||
 | 
			
		||||
data PostBook = PostBook { contentType :: Text
 | 
			
		||||
                         , title :: Maybe Text
 | 
			
		||||
                         , title :: Text
 | 
			
		||||
                         , description :: Maybe Text
 | 
			
		||||
                         , channels :: [Text]
 | 
			
		||||
                         , tags :: [Text] }
 | 
			
		||||
@@ -61,7 +61,9 @@ 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 :> Get '[OctetStream] ByteString
 | 
			
		||||
       :<|> GetBook
 | 
			
		||||
 | 
			
		||||
type GetBook = "books" :> Capture "book_id" BookID :> Get '[OctetStream] ByteString
 | 
			
		||||
 | 
			
		||||
handler :: ServerT API AppM
 | 
			
		||||
handler user = listBooksHandler user
 | 
			
		||||
@@ -14,17 +14,19 @@
 | 
			
		||||
{-# Language TemplateHaskell #-}
 | 
			
		||||
{-# Language MultiParamTypeClasses #-}
 | 
			
		||||
{-# Language ScopedTypeVariables #-}
 | 
			
		||||
module API.Catalogue (VersionedAPI, handler) where
 | 
			
		||||
module Server.API.Catalogue (VersionedAPI, handler) where
 | 
			
		||||
 | 
			
		||||
import Types
 | 
			
		||||
import Servant
 | 
			
		||||
import Servant hiding (contentType)
 | 
			
		||||
import ClassyPrelude
 | 
			
		||||
import GHC.TypeLits
 | 
			
		||||
import Server.Auth
 | 
			
		||||
import Servant.Auth as SA
 | 
			
		||||
import Servant.XML
 | 
			
		||||
import qualified Database.Channel as Channel
 | 
			
		||||
import Database.Book (Book(..))
 | 
			
		||||
import Database
 | 
			
		||||
import qualified Server.API.Books as API.Books
 | 
			
		||||
 | 
			
		||||
-- This is my first try on going to versioned apis, things might change
 | 
			
		||||
-- I think my rule of thumb is that you can add new things as you want, but
 | 
			
		||||
@@ -96,15 +98,40 @@ instance ToNode (Catalog 1) where
 | 
			
		||||
 | 
			
		||||
class Monad m => VersionedCatalog m (v :: Nat) where
 | 
			
		||||
  getChannels :: SafeUser -> m (Catalog v)
 | 
			
		||||
  getBooks :: Channel.ChannelID -> SafeUser -> m (Catalog v)
 | 
			
		||||
 | 
			
		||||
instance VersionedCatalog AppM 1 where
 | 
			
		||||
  getChannels SafeUser{username} = do
 | 
			
		||||
  getChannels = getChannelsV1
 | 
			
		||||
  getBooks = getBooksV1
 | 
			
		||||
 | 
			
		||||
relUrl :: Link -> Rel
 | 
			
		||||
relUrl x = Rel ("/api/current/" <> (pack . uriPath . linkURI $ x))
 | 
			
		||||
 | 
			
		||||
getBooksV1 :: Channel.ChannelID -> SafeUser -> AppM (Catalog 1)
 | 
			
		||||
getBooksV1 channelID SafeUser{username} = do
 | 
			
		||||
  updated <- liftIO getCurrentTime
 | 
			
		||||
    let self = Rel ("/api/current/" <> selfUrl)
 | 
			
		||||
  let self = relUrl selfUrl
 | 
			
		||||
      start = relUrl startUrl
 | 
			
		||||
      selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) channelID
 | 
			
		||||
      startUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
 | 
			
		||||
      pagination = Pagination Nothing Nothing
 | 
			
		||||
  entries <- map (toEntry updated) <$> runDB (Channel.channelBooks username channelID)
 | 
			
		||||
  pure CatalogV1{..}
 | 
			
		||||
  where
 | 
			
		||||
    toEntry updated Book{description,title,identifier=bookId} =
 | 
			
		||||
      let content = fromMaybe "no content" description
 | 
			
		||||
          identifier = pack . show $ bookId
 | 
			
		||||
          link = Right (Acquisition (relUrl (safeLink (Proxy @API.Books.BaseAPI) (Proxy @API.Books.GetBook) bookId)))
 | 
			
		||||
      in EntryV1{..}
 | 
			
		||||
 | 
			
		||||
getChannelsV1 :: SafeUser -> AppM (Catalog 1)
 | 
			
		||||
getChannelsV1 SafeUser{username} = do
 | 
			
		||||
  updated <- liftIO getCurrentTime
 | 
			
		||||
  let self = relUrl selfUrl
 | 
			
		||||
      -- I'm not sure if this safe link approach is really useable with this
 | 
			
		||||
      -- api hierarchy since I can't access the topmost api from here. Also
 | 
			
		||||
      -- authentication would bring a little bit of extra effort as well
 | 
			
		||||
        selfUrl = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
 | 
			
		||||
      selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
 | 
			
		||||
      start = self
 | 
			
		||||
      pagination = Pagination Nothing Nothing
 | 
			
		||||
  entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username)
 | 
			
		||||
@@ -112,14 +139,16 @@ instance VersionedCatalog AppM 1 where
 | 
			
		||||
  where
 | 
			
		||||
    fromChannel :: UTCTime -> Channel.Channel -> Entry 1
 | 
			
		||||
    fromChannel updated Channel.Channel{..} =
 | 
			
		||||
        let url = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
 | 
			
		||||
            self = Rel ("/api/current/" <> url)
 | 
			
		||||
      let url = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
 | 
			
		||||
          self = relUrl url
 | 
			
		||||
      in EntryV1 channel channel updated channel (Left $ SubSection self)
 | 
			
		||||
 | 
			
		||||
type VersionedAPI (v :: Nat) = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI v
 | 
			
		||||
 | 
			
		||||
type RootCatalog (v :: Nat) = "catalog" :> Get '[XML] (Catalog v)
 | 
			
		||||
type ChannelCatalog (v :: Nat) = "catalog" :> "channel" :> Capture "channel_id" Channel.ChannelID :> Get '[XML] (Catalog v)
 | 
			
		||||
type CatalogContent = '[XML, OPDS]
 | 
			
		||||
 | 
			
		||||
type RootCatalog (v :: Nat) = "catalog" :> Get CatalogContent (Catalog v)
 | 
			
		||||
type ChannelCatalog (v :: Nat) = "catalog" :> "channel" :> Capture "channel_id" Channel.ChannelID :> Get CatalogContent (Catalog v)
 | 
			
		||||
type BaseAPI (v :: Nat) = RootCatalog v
 | 
			
		||||
                    :<|> ChannelCatalog v
 | 
			
		||||
 | 
			
		||||
@@ -127,6 +156,8 @@ handler :: forall v. VersionedCatalog AppM v => ServerT (VersionedAPI v) AppM
 | 
			
		||||
handler auth = catalogRoot :<|> catalogChannels
 | 
			
		||||
  where
 | 
			
		||||
    catalogChannels :: Channel.ChannelID -> AppM (Catalog v)
 | 
			
		||||
    catalogChannels _ = throwM err403{errBody="Not implemented"}
 | 
			
		||||
    -- Channel specific catalog returns tags inside the catalog
 | 
			
		||||
    catalogChannels identifier = flip requireLoggedIn auth (getBooks identifier)
 | 
			
		||||
    catalogRoot :: AppM (Catalog v)
 | 
			
		||||
    -- catalog root returns channels
 | 
			
		||||
    catalogRoot = flip requireLoggedIn auth getChannels
 | 
			
		||||
@@ -13,7 +13,7 @@
 | 
			
		||||
{-# Language DataKinds #-}
 | 
			
		||||
{-# Language DuplicateRecordFields #-}
 | 
			
		||||
{-# Language NamedFieldPuns #-}
 | 
			
		||||
module API.Channels (API, handler, JsonChannel(..)) where
 | 
			
		||||
module Server.API.Channels (API, handler, JsonChannel(..)) where
 | 
			
		||||
 | 
			
		||||
import Servant
 | 
			
		||||
import Types
 | 
			
		||||
@@ -5,7 +5,7 @@
 | 
			
		||||
{-# Language TypeOperators #-}
 | 
			
		||||
{-# Language DuplicateRecordFields #-}
 | 
			
		||||
{-# Language TypeApplications #-}
 | 
			
		||||
module API.Users  where
 | 
			
		||||
module Server.API.Users  where
 | 
			
		||||
 | 
			
		||||
import Servant
 | 
			
		||||
import ClassyPrelude
 | 
			
		||||
@@ -24,21 +24,8 @@ import Control.Lens (view)
 | 
			
		||||
import Data.Generics.Product
 | 
			
		||||
import Servant (err401)
 | 
			
		||||
import Control.Monad.Logger
 | 
			
		||||
import Auth (SafeUser(..))
 | 
			
		||||
 | 
			
		||||
-- 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
 | 
			
		||||
                         , username :: Username
 | 
			
		||||
                         , role :: Role }
 | 
			
		||||
              deriving (Show, Generic)
 | 
			
		||||
 | 
			
		||||
instance ToJSON SafeUser where
 | 
			
		||||
instance FromJSON SafeUser where
 | 
			
		||||
instance ToJWT SafeUser where
 | 
			
		||||
instance FromJWT SafeUser where
 | 
			
		||||
 | 
			
		||||
type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult SafeUser)
 | 
			
		||||
 | 
			
		||||
							
								
								
									
										30
									
								
								common/LICENSE
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										30
									
								
								common/LICENSE
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1,30 @@
 | 
			
		||||
Copyright (c) 2018, Mats Rauhala
 | 
			
		||||
 | 
			
		||||
All rights reserved.
 | 
			
		||||
 | 
			
		||||
Redistribution and use in source and binary forms, with or without
 | 
			
		||||
modification, are permitted provided that the following conditions are met:
 | 
			
		||||
 | 
			
		||||
    * Redistributions of source code must retain the above copyright
 | 
			
		||||
      notice, this list of conditions and the following disclaimer.
 | 
			
		||||
 | 
			
		||||
    * Redistributions in binary form must reproduce the above
 | 
			
		||||
      copyright notice, this list of conditions and the following
 | 
			
		||||
      disclaimer in the documentation and/or other materials provided
 | 
			
		||||
      with the distribution.
 | 
			
		||||
 | 
			
		||||
    * Neither the name of Mats Rauhala nor the names of other
 | 
			
		||||
      contributors may be used to endorse or promote products derived
 | 
			
		||||
      from this software without specific prior written permission.
 | 
			
		||||
 | 
			
		||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 | 
			
		||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 | 
			
		||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 | 
			
		||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 | 
			
		||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 | 
			
		||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 | 
			
		||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 | 
			
		||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 | 
			
		||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 | 
			
		||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 | 
			
		||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 | 
			
		||||
							
								
								
									
										48
									
								
								common/common.cabal
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										48
									
								
								common/common.cabal
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1,48 @@
 | 
			
		||||
name:                common
 | 
			
		||||
version:             0.1.0.0
 | 
			
		||||
-- synopsis:
 | 
			
		||||
-- description:
 | 
			
		||||
license:             BSD3
 | 
			
		||||
license-file:        LICENSE
 | 
			
		||||
author:              Mats Rauhala
 | 
			
		||||
maintainer:          mats.rauhala@iki.fi
 | 
			
		||||
-- copyright:
 | 
			
		||||
category:            Web
 | 
			
		||||
build-type:          Simple
 | 
			
		||||
extra-source-files:  ChangeLog.md
 | 
			
		||||
cabal-version:       >=1.10
 | 
			
		||||
 | 
			
		||||
library
 | 
			
		||||
  exposed-modules:     Configuration
 | 
			
		||||
                     , Data.Versioned
 | 
			
		||||
                     , API
 | 
			
		||||
                     , API.Books
 | 
			
		||||
                     , API.Catalogue
 | 
			
		||||
                     , API.Channels
 | 
			
		||||
                     , API.Users
 | 
			
		||||
                     , Auth
 | 
			
		||||
  -- other-extensions:
 | 
			
		||||
  build-depends:       base >=4.10 && <4.11
 | 
			
		||||
                     , aeson
 | 
			
		||||
                     , classy-prelude
 | 
			
		||||
                     , dhall
 | 
			
		||||
                     , foreign-store
 | 
			
		||||
                     , generic-lens
 | 
			
		||||
                     , lens
 | 
			
		||||
                     , mtl
 | 
			
		||||
                     , servant
 | 
			
		||||
                     , servant-auth
 | 
			
		||||
                     , servant-auth-server
 | 
			
		||||
                     , servant-docs
 | 
			
		||||
                     , servant-lucid
 | 
			
		||||
                     , servant-multipart
 | 
			
		||||
                     , text
 | 
			
		||||
                     , transformers
 | 
			
		||||
  hs-source-dirs:      src
 | 
			
		||||
  default-extensions:  DeriveGeneric
 | 
			
		||||
                     , NoImplicitPrelude
 | 
			
		||||
                     , OverloadedStrings
 | 
			
		||||
                     , RecordWildCards
 | 
			
		||||
                     , TypeOperators
 | 
			
		||||
                     , DataKinds
 | 
			
		||||
  default-language:    Haskell2010
 | 
			
		||||
							
								
								
									
										1
									
								
								common/src/API.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										1
									
								
								common/src/API.hs
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1 @@
 | 
			
		||||
module API where
 | 
			
		||||
							
								
								
									
										1
									
								
								common/src/API/Books.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										1
									
								
								common/src/API/Books.hs
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1 @@
 | 
			
		||||
module API.Books where
 | 
			
		||||
							
								
								
									
										1
									
								
								common/src/API/Catalogue.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										1
									
								
								common/src/API/Catalogue.hs
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1 @@
 | 
			
		||||
module API.Catalogue where
 | 
			
		||||
							
								
								
									
										27
									
								
								common/src/API/Channels.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										27
									
								
								common/src/API/Channels.hs
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1,27 @@
 | 
			
		||||
{-# Language DuplicateRecordFields #-}
 | 
			
		||||
module API.Channels (API) where
 | 
			
		||||
 | 
			
		||||
import Auth
 | 
			
		||||
import ClassyPrelude
 | 
			
		||||
import Data.Aeson
 | 
			
		||||
import Servant.API
 | 
			
		||||
import Servant.Auth as SA
 | 
			
		||||
 | 
			
		||||
data JsonChannel = JsonChannel { channel :: Text
 | 
			
		||||
                               , visibility :: Visibility }
 | 
			
		||||
                 deriving (Show, Generic)
 | 
			
		||||
data UpdateChannel = UpdateChannel { identifier :: ChannelID
 | 
			
		||||
                                   , channel :: Text
 | 
			
		||||
                                   , visibility :: Visibility }
 | 
			
		||||
                 deriving (Show, Generic)
 | 
			
		||||
 | 
			
		||||
instance ToJSON JsonChannel
 | 
			
		||||
instance FromJSON JsonChannel
 | 
			
		||||
instance ToJSON UpdateChannel
 | 
			
		||||
instance FromJSON UpdateChannel
 | 
			
		||||
 | 
			
		||||
type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI
 | 
			
		||||
 | 
			
		||||
type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] UpdateChannel
 | 
			
		||||
          :<|> "channels" :> Capture "channel_id" ChannelID :> ReqBody '[JSON] UpdateChannel :> Put '[JSON] UpdateChannel
 | 
			
		||||
          :<|> "channels" :> Get '[JSON] [JsonChannel]
 | 
			
		||||
							
								
								
									
										1
									
								
								common/src/API/Users.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										1
									
								
								common/src/API/Users.hs
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1 @@
 | 
			
		||||
module API.Users where
 | 
			
		||||
							
								
								
									
										26
									
								
								common/src/Auth.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										26
									
								
								common/src/Auth.hs
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1,26 @@
 | 
			
		||||
{-# Language GeneralizedNewtypeDeriving #-}
 | 
			
		||||
module Auth where
 | 
			
		||||
 | 
			
		||||
import ClassyPrelude
 | 
			
		||||
import Data.Aeson
 | 
			
		||||
import Servant.Auth.Server (ToJWT, FromJWT)
 | 
			
		||||
import Servant.API
 | 
			
		||||
 | 
			
		||||
-- 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?
 | 
			
		||||
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
 | 
			
		||||
 | 
			
		||||
newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
 | 
			
		||||
 | 
			
		||||
data SafeUser = SafeUser { email :: Email
 | 
			
		||||
                         , username :: Username
 | 
			
		||||
                         }
 | 
			
		||||
              deriving (Show, Generic)
 | 
			
		||||
 | 
			
		||||
instance ToJSON SafeUser where
 | 
			
		||||
instance FromJSON SafeUser where
 | 
			
		||||
instance ToJWT SafeUser where
 | 
			
		||||
instance FromJWT SafeUser where
 | 
			
		||||
							
								
								
									
										20
									
								
								default.nix
									
									
									
									
									
								
							
							
						
						
									
										20
									
								
								default.nix
									
									
									
									
									
								
							@@ -1,10 +1,12 @@
 | 
			
		||||
{ mkDerivation, base, stdenv }:
 | 
			
		||||
mkDerivation {
 | 
			
		||||
  pname = "ebook-manager";
 | 
			
		||||
  version = "0.1.0.0";
 | 
			
		||||
  src = ./.;
 | 
			
		||||
  isLibrary = false;
 | 
			
		||||
  isExecutable = true;
 | 
			
		||||
  executableHaskellDepends = [ base ];
 | 
			
		||||
  license = stdenv.lib.licenses.bsd3;
 | 
			
		||||
{ nixpkgs, haskellPackages }:
 | 
			
		||||
 | 
			
		||||
(import ./project.nix nixpkgs) {
 | 
			
		||||
  packages = {
 | 
			
		||||
    common = ./common;
 | 
			
		||||
    backend = ./backend;
 | 
			
		||||
  };
 | 
			
		||||
  tools = with haskellPackages; [
 | 
			
		||||
    ghcid
 | 
			
		||||
    hasktags
 | 
			
		||||
  ];
 | 
			
		||||
}
 | 
			
		||||
 
 | 
			
		||||
							
								
								
									
										38
									
								
								project.nix
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										38
									
								
								project.nix
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1,38 @@
 | 
			
		||||
nixpkgs:
 | 
			
		||||
 | 
			
		||||
let
 | 
			
		||||
 | 
			
		||||
  inherit (nixpkgs.lib) mapAttrs mapAttrsToList escapeShellArg optionalString concatStringsSep concatMapStringsSep;
 | 
			
		||||
 | 
			
		||||
in
 | 
			
		||||
 | 
			
		||||
{ packages
 | 
			
		||||
, overrides ? _ : _ : {}
 | 
			
		||||
, tools ? []
 | 
			
		||||
}:
 | 
			
		||||
 | 
			
		||||
let
 | 
			
		||||
 | 
			
		||||
  overrides' = nixpkgs.lib.foldr nixpkgs.lib.composeExtensions (_: _: {}) [
 | 
			
		||||
    (self: super: mapAttrs (name: path: self.callCabal2nix name path {}) packages)
 | 
			
		||||
  ];
 | 
			
		||||
  haskellPackages = nixpkgs.haskellPackages.override { overrides = overrides'; };
 | 
			
		||||
  packages' = mapAttrs (name: _: haskellPackages."${name}") packages;
 | 
			
		||||
  mkShell = name: pkg:
 | 
			
		||||
  let
 | 
			
		||||
    n =  "${name}-shell";
 | 
			
		||||
    deps = haskellPackages.ghcWithPackages (pkgs: pkg.buildInputs);
 | 
			
		||||
  in
 | 
			
		||||
  {
 | 
			
		||||
    name = "${n}";
 | 
			
		||||
    value = nixpkgs.buildEnv {
 | 
			
		||||
      name = "${n}";
 | 
			
		||||
      paths = tools ++ [deps];
 | 
			
		||||
      buildInputs = tools ++ [deps];
 | 
			
		||||
    };
 | 
			
		||||
  };
 | 
			
		||||
  shells = nixpkgs.lib.listToAttrs (mapAttrsToList mkShell packages');
 | 
			
		||||
 | 
			
		||||
in
 | 
			
		||||
 | 
			
		||||
packages' // shells
 | 
			
		||||
							
								
								
									
										15
									
								
								release.nix
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										15
									
								
								release.nix
									
									
									
									
									
										Normal file
									
								
							@@ -0,0 +1,15 @@
 | 
			
		||||
{ nixpkgs ? import <nixpkgs> {} }:
 | 
			
		||||
 | 
			
		||||
let
 | 
			
		||||
 | 
			
		||||
  pinnedVersion = nixpkgs.lib.importJSON ./nixpkgs-version.json;
 | 
			
		||||
  pinnedPkgs = import (nixpkgs.fetchFromGitHub {
 | 
			
		||||
    owner = "NixOS";
 | 
			
		||||
    repo = "nixpkgs";
 | 
			
		||||
    inherit (pinnedVersion) rev sha256;
 | 
			
		||||
  }) {};
 | 
			
		||||
  inherit (pinnedPkgs) pkgs;
 | 
			
		||||
 | 
			
		||||
  in
 | 
			
		||||
 | 
			
		||||
import ./default.nix { nixpkgs = pinnedPkgs; haskellPackages = pinnedPkgs.haskellPackages; }
 | 
			
		||||
		Reference in New Issue
	
	Block a user