hablo-1.0.0.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]
  }

articleP :: Parser (String, Metadata, Int, [String])
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
  )
  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

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

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)

at :: FilePath -> IO (Either ParseError (String, Article))
at filePath = do
  tzOffset <- timeZoneOffsetString <$> getCurrentTimeZone
  fileDate <- modificationTime <$> getFileStatus filePath
  let build = makeArticle (setDate tzOffset fileDate)
  fmap build . parse articleP filePath <$> readFile filePath
  where
    makeArticle metaFilter (title, metadata, bodyOffset, body) = (
          getKey filePath
        , Article {
              key = getKey filePath
            , title
            , metadata = metaFilter metadata
            , bodyOffset
            , body
          }
      )

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

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