Content extraction and persistence using Pandoc & Lenses

Question

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:

data PagedDocument = PagedDocument Int [Block]

instance ToJSON PagedDocument where
  toJSON (PagedDocument page blocks) = object
    [ "blocks" .= blocks
    , "page" .= page
    ]

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

Answer 1

I don't see the definition for PagedDocument, and your first code paragraph doesn't look like Haskell to me.

You have one more place where you could use your eitherToMaybe. Both uses are for readHtml, so you could instead wrap readHtml in your name for it which returns a Maybe.

Assuming a _content lens into the content field of PagedDocument:

injectStreams = mapMOf (_content . each . blockInlines) extractStream (note that mapMOf = id)

The source of https://hackage.haskell.org/package/pandoc-lens-0.6.2/docs/Text-Pandoc-Lens.html#t:HasAttr seems to want to give you the attributes in Code Inlines too. Maybe they have reason for this - should you also retrieve that in streamToId? If so:

getStreamId = Json.parse <=< preview (attributes . _3 . traverse . itraversed . index "stream-id")

In general, I think everything that's used only once should be inlined - for example injectStreams like:

forMOf (_Just . _content . each . blockInlines) (getPage page =<< mDoc) extractStream