hablo-1.1.0.1: src/Article.hs

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

import Control.Applicative ((<|>))
import qualified Data.Map as Map (alter)
import Data.Time (defaultTimeLocale, getCurrentTimeZone, parseTimeM, timeZoneOffsetString)
import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
import Foreign.C.Types (CTime)
import Markdown (Markdown(..), MarkdownContent(..), Metadata)
import qualified Markdown (at)
import System.Posix.Files (getFileStatus, modificationTime)
import Text.ParserCombinators.Parsec (ParseError)

newtype Article = Article Markdown
instance MarkdownContent Article where
  getMarkdown (Article markdown) = markdown

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 :: (Metadata -> Metadata) -> Markdown -> (String, Article)
makeArticle metaFilter markdown@(Markdown {key, metadata}) =
  (key, Article $ markdown {metadata = metaFilter metadata})

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

preview :: Int -> Article -> Markdown
preview linesCount (Article markdown@(Markdown {body})) =
  markdown {body = take linesCount $ body}