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