Извлечение содержимого и упорство с помощью Pandoc и объективы


Конечные точки, чтобы сохранить документ Pandoc к базе данных с использованием стойких. До того, чтобы быть сохраненным, код удаляет все пункт содержания ( [Inline]'Ы) и сохраняет их с помощью типа Stream. Каждая добыча отмечен соответствующим Stream ID в Pandoc документа (т. е. <span data-stream-id="3"/> в HTML).

Когда дело доходит до чтения, акция расширяет документа добавление в каждом потоке с соответствующего идентификатора, так что контент будет закачиваться обратно в документ. Еще один кусок функциональности чтения обеспечивает разбиение на страницы, так /read/:id/5 читает 5-й блок из [Block]'ы, которые составляют документ.

Соответствующих видах:

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

Постоянные функции для сохранения документа в БД при загрузке:

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 для действий:

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:

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


124
4
задан 2 февраля 2018 в 09:02 Источник Поделиться
Комментарии
1 ответ

Я не вижу определения PagedDocumentи ваш первый код пункта не похож на Haskell для меня.

У вас есть одно место, где вы могли использовать свой eitherToMaybe. В обоих случаях используется для readHtml, Так что вы могли бы вместо обруча readHtml в ваше имя для него, который возвращает Maybe.

Предполагая _content объектив в поле содержимое PagedDocument:

injectStreams = mapMOf (_content . each . blockInlines) extractStream (обратите внимание, что mapMOf = id)

Источник https://hackage.haskell.org/package/pandoc-lens-0.6.2/docs/Text-Pandoc-Lens.html#t:HasAttr кажется, хочет дать вам атрибуты Code Inlineслишком. Может у них есть причины для этого - следует также получить, что в streamToId? Если так:

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

В общем, я думаю, что все это используется только один раз должен быть встроенным, например injectStreams как:

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

1
ответ дан 3 февраля 2018 в 02:02 Источник Поделиться