Endpoints to save a Pandoc document to the database using persistent. Prior to being stored, the code strips out all of the paragraph content (the [Inline]‘s) and stores these using the type Stream. Each extraction is marked with the relevant Stream id in the Pandoc document (ie <span data-stream-id="3"/> in HTML).

When it comes to reading, the action expands the document adding in each stream with it’s corresponding ID, so content is re-injected back into the document. Another piece of functionality the read action provides is pagination, so /read/:id/5 reads the 5th block out of the [Block]‘s that make up the document.

Relevant types:

DocumentListing     position Int     lastAccessed UTCTime Maybe     belongs AccountId     document DocumentId     deriving Eq Show Document     title String     body String     created UTCTime Maybe     deriving Eq Show Stream     content String     deriving Eq Show 

Persistent function to save document to DB when uploaded:

data ExtractedStream =   ExtractedStream     { unStreamId :: String     , unStreamElements :: [Block]     }  createDocument :: MonadIO m => String -> Pandoc -> Key Account -> SqlPersistT m (Key Document) createDocument title pandoc owner = do   now <- liftIO getCurrentTime   extractedPandoc <- extractStreams pandoc   key_ <- insert $   Document title (writeHtmlString def extractedPandoc) (Just now)   _ <- insert $   DocumentListing 0 Nothing owner key_   pure key_  extractStreams :: MonadIO m => Pandoc -> SqlPersistT m Pandoc extractStreams = mapMOf (body . each . _Para) f   where     f :: MonadIO m => [Inline] -> SqlPersistT m [Inline]     f els = do       streamId <- insert . Stream . writeHtmlString def . wrapPlain $   els       pure [ createStreamElement streamId ]  createStreamElement :: Key Stream -> Inline createStreamElement streamId = Span ("", [], [("stream-id", show . fromSqlKey $   streamId)]) []  wrapPlain :: [Inline] -> Pandoc wrapPlain = Pandoc nullMeta . (: []) . Plain  unwrapPlain :: Pandoc -> [Inline] unwrapPlain = toListOf (each . blockInlines) . view body 

Api action:

show :: Config -> AuthResult (Key Account) -> Int64 -> Int -> Handler PagedDocument show config auth docId page =   case auth of     Authenticated acc ->       maybe (throw404 "Document not found") pure =<<         runSqlPool (getPagedDocument acc docId page) (getPool config)     _ ->       throwAll err401  getPagedDocument :: MonadIO m => Key Account -> Int64 -> Int -> SqlPersistT m (Maybe PagedDocument) getPagedDocument acc docId page = do   _ <- Queries.updateDocumentPosition docId acc page   mDoc <- getDocument docId   mapM injectStreams (getPage page =<< mDoc)  getPage :: Int -> Document -> Maybe PagedDocument getPage page (Document _ body _) =   either (const Nothing) Just $   createPagedDocument . unPandocBody <$  > readHtml def body   where     createPagedDocument pages = PagedDocument page' . take 1 . drop page' $   pages       where page' = max 0 . min (length pages - 1) $   page  unPandocBody :: Pandoc -> [Block] unPandocBody (Pandoc _ body) = body  injectStreams :: MonadIO m => PagedDocument -> SqlPersistT m PagedDocument injectStreams (PagedDocument num content) = do   injected <- mapMOf (each . blockInlines) extractStream content   pure $   PagedDocument num injected   where     extractStream :: MonadIO m => Inline -> SqlPersistT m Inline     extractStream el =       case getStreamId el of           Just sid -> do             x <- get . toSqlKey $   sid             pure . M.fromMaybe invalidStream $   streamToInline =<< x           Nothing -> pure streamNotFound  streamToInline :: Stream -> Maybe Inline streamToInline (Stream content) =   eitherToMaybe $   Span ("sentence", [], []) . unwrapPlain <$  > readHtml def content  eitherToMaybe :: Either b a -> Maybe a eitherToMaybe = either (const Nothing) Just  streamNotFound :: Inline streamNotFound = Span nullAttr [ Str "<Stream not found>" ]  invalidStream :: Inline invalidStream = Span nullAttr [ Str "<Invalid stream>" ]  getStreamId :: Inline -> Maybe Int64 getStreamId = \case   Span (_, _, attr) _ -> Json.parse . snd =<< find ((==) "stream-id" . fst) attr   _ -> Nothing  find :: (a -> Bool) -> [a] -> Maybe a find f = M.listToMaybe . filter f 

Json helper:

import           Data.Aeson import qualified Data.Text.Lazy               as LT import           Data.Text.Lazy.Encoding  parse :: (FromJSON a) => String -> Maybe a parse = decode . encodeUtf8 . LT.pack  stringify :: (ToJSON a) => a -> String stringify = LT.unpack . decodeUtf8 . encode