hablo-1.0.1.0: src/Article.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Article (
      Article(..)
    , at
    , getKey
    , preview
  ) where

import Control.Applicative ((<|>))
import Data.Map (Map)
import qualified Data.Map as Map (fromList, alter)
import Data.Time (defaultTimeLocale, getCurrentTimeZone, parseTimeM, timeZoneOffsetString)
import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
import Foreign.C.Types (CTime)
import System.FilePath (dropExtension, takeFileName)
import System.Posix.Files (getFileStatus, modificationTime)
import Text.ParserCombinators.Parsec (
      ParseError
    , Parser
    , (<?>)
    , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf
    , oneOf, option, parse, skipMany, sourceLine, string, try
  )

type Metadata = Map String String

data Article = Article {
      key :: String
    , title :: String
    , metadata :: Metadata
    , bodyOffset :: Int
    , body :: [String]
  }

type ProtoArticle = (String, Metadata, Int, [String])

articleP :: Parser ProtoArticle
articleP =
  skipMany eol *> headerP <* skipMany eol <*> lineOffset <*> bodyP
  where
    headerP =
        try ((,,,) <$> titleP <* many eol <*> metadataP)
      <|> flip (,,,) <$> metadataP  <* many eol<*> titleP
    lineOffset = pred . sourceLine <$> getPosition
    bodyP = lines <$> many anyChar <* eof

metadataP :: Parser Metadata
metadataP = Map.fromList <$> option [] (
    metaSectionSeparator *> many eol *>
    (try keyVal) `endBy` (many1 eol)
    <* metaSectionSeparator
  ) <?> "metadata section"
  where
    metaSectionSeparator = count 3 (oneOf "~-") *> eol
    spaces = skipMany $ char ' '
    keyVal = (,) <$> (no ": \r\n" <* spaces <* char ':' <* spaces) <*> no "\r\n"

titleP :: Parser String
titleP = try (singleLine <|> underlined)
  where
    singleLine = char '#' *> char ' ' *> no "\r\n" <* eol
    underlined =
      no "\r\n" <* eol
      >>= \titleLine -> count (length titleLine) (oneOf "#=") *> eol *> return titleLine
      <?> "'#' or '=' to underline the title"

eol :: Parser String
eol = try (string "\r\n") <|> string "\r" <|> string "\n" <?> "newline"

no :: String -> Parser String
no = many1 . noneOf

setDate :: String -> CTime -> Metadata -> Metadata
setDate tzOffset defaultDate = Map.alter timeStamp "date"
  where
    formats = ("%Y-%m-%d" ++) . (++ " %z") <$> ["", " %H:%M"]
    epoch = show . (truncate :: POSIXTime -> Integer) . utcTimeToPOSIXSeconds
    timeStamp Nothing = Just $ show defaultDate
    timeStamp (Just date) =
      let dates = [date, date ++ " " ++ tzOffset] in
      let parsedTimes = parseTimeM True defaultTimeLocale <$> formats <*> dates in
      foldr (<|>) (timeStamp Nothing) (fmap epoch <$> parsedTimes)

makeArticle :: FilePath -> (Metadata -> Metadata) -> ProtoArticle -> (String, Article)
makeArticle filePath metaFilter (title, metadata, bodyOffset, body) = (
      getKey filePath
    , Article {
          key = getKey filePath
        , title
        , metadata = metaFilter metadata
        , bodyOffset
        , body
      }
  )

at :: FilePath -> IO (Either ParseError (String, Article))
at filePath = do
  tzOffset <- timeZoneOffsetString <$> getCurrentTimeZone
  fileDate <- modificationTime <$> getFileStatus filePath
  let build = makeArticle filePath (setDate tzOffset fileDate)
  fmap build . parse articleP filePath <$> readFile filePath

getKey :: FilePath -> String
getKey = dropExtension . takeFileName

preview :: Int -> Article -> Article
preview linesCount article = article {body = take linesCount $ body article}