220 lines
7.7 KiB
Haskell
220 lines
7.7 KiB
Haskell
--------------------------------------------------------------------------------
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
--------------------------------------------------------------------------------
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
import Data.Monoid (mappend)
|
|
import Hakyll
|
|
import Data.Maybe (fromMaybe)
|
|
import Text.Read (readMaybe)
|
|
import Control.Monad (liftM)
|
|
import Data.List ( sortBy, isInfixOf, intercalate )
|
|
import Data.Ord (comparing)
|
|
-- import HakyllMedia.Image
|
|
import System.FilePath.Posix ( takeDirectory
|
|
, takeBaseName
|
|
, (</>)
|
|
, splitFileName
|
|
)
|
|
import Control.Applicative (empty)
|
|
|
|
|
|
import qualified Data.HashMap.Strict as HMS
|
|
import qualified Data.Set as S
|
|
import qualified Data.Text as T
|
|
import qualified Data.Yaml as Yaml
|
|
import qualified Data.Text as T
|
|
import qualified Data.Vector as V
|
|
import Data.Yaml
|
|
import Data.Scientific
|
|
|
|
import Data.Yaml.Parser (FromYaml (fromYaml), YamlValue (Mapping), YamlParser)
|
|
import GHC.Generics (Generic)
|
|
import Data.Yaml (FromJSON)
|
|
import Data.Yaml.Aeson ((.:))
|
|
import qualified Data.Aeson.Key as AK
|
|
import qualified Data.Aeson.KeyMap as KeyMap
|
|
import Data.Yaml.Aeson (Value(Object))
|
|
import Data.Map (mapMaybe)
|
|
|
|
--------------------------------------------------------------------------------
|
|
main :: IO ()
|
|
main = hakyll $ do
|
|
match "content/images/*" $ do
|
|
route rmContentPrefix
|
|
compile copyFileCompiler
|
|
|
|
match "content/css/*" $ do
|
|
route rmContentPrefix
|
|
compile compressCssCompiler
|
|
|
|
match "content/cv/*" $ compile $ pandocCompiler
|
|
>>= loadAndApplyTemplate "templates/cv-section.html" cvSecCtx
|
|
>>= relativizeUrls
|
|
>>= rmIndexHtml
|
|
|
|
match (fromList ["content/about.md", "content/contact.md"]) $ compile $ pandocCompiler
|
|
>>= loadAndApplyTemplate "templates/section.html" defaultContext
|
|
>>= relativizeUrls
|
|
>>= rmIndexHtml
|
|
|
|
match "content/posts/*" $ do
|
|
route $ rmContentPrefix `composeRoutes` niceRoute
|
|
compile $ pandocCompiler
|
|
>>= loadAndApplyTemplate "templates/post.html" postCtx
|
|
>>= loadAndApplyTemplate "templates/default.html" postCtx
|
|
-- >>= mkResponsiveImage
|
|
>>= relativizeUrls
|
|
>>= rmIndexHtml
|
|
|
|
create ["archive.html"] $ do
|
|
route niceRoute
|
|
compile $ do
|
|
posts <- recentFirst =<< loadAll "content/posts/*"
|
|
let archiveCtx =
|
|
listField "posts" postCtx (return posts) `mappend`
|
|
constField "title" "Archives" `mappend`
|
|
defaultContext
|
|
|
|
makeItem ""
|
|
>>= loadAndApplyTemplate "templates/archive.html" archiveCtx
|
|
>>= loadAndApplyTemplate "templates/default.html" archiveCtx
|
|
>>= relativizeUrls
|
|
>>= rmIndexHtml
|
|
|
|
create ["cv.html"] $ do
|
|
route niceRoute
|
|
compile $ do
|
|
sections <- byPriority =<< loadAll "content/cv/*"
|
|
let cvCtx =
|
|
listField "sections" defaultContext (return sections) `mappend`
|
|
defaultContext
|
|
|
|
makeItem ""
|
|
>>= loadAndApplyTemplate "templates/cv.html" cvCtx
|
|
>>= loadAndApplyTemplate "templates/default.html" cvCtx
|
|
>>= relativizeUrls
|
|
>>= rmIndexHtml
|
|
|
|
match "content/index.html" $ do
|
|
route rmContentPrefix
|
|
compile $ do
|
|
posts <- fmap (take 3) $ recentFirst =<< loadAll "content/posts/*"
|
|
aboutStub <- loadBody "content/about.md"
|
|
contactStub <- loadBody "content/contact.md"
|
|
let indexCtx =
|
|
listField "posts" postCtx (return posts) `mappend`
|
|
constField "about" aboutStub `mappend`
|
|
constField "contact" contactStub `mappend`
|
|
defaultContext
|
|
|
|
getResourceBody
|
|
>>= applyAsTemplate indexCtx
|
|
>>= loadAndApplyTemplate "templates/default.html" indexCtx
|
|
>>= relativizeUrls
|
|
>>= rmIndexHtml
|
|
|
|
match "templates/*" $ compile templateBodyCompiler
|
|
|
|
rmContentPrefix = gsubRoute "content/" (const "")
|
|
|
|
--------------------------------------------------------------------------------
|
|
postCtx :: Context String
|
|
postCtx =
|
|
dateField "date" "%Y-%m-%d" `mappend`
|
|
defaultContext
|
|
|
|
cvSecCtx :: Context String
|
|
cvSecCtx =
|
|
customCtx "heading" `mappend`
|
|
defaultContext `mappend`
|
|
skillsCtx
|
|
|
|
customCtx :: String -> Context a
|
|
customCtx key = field key $ \item -> do
|
|
metadata <- getMetadata (itemIdentifier item)
|
|
return $ fromMaybe "" $ lookupString key metadata
|
|
|
|
skillsCtx :: Context String
|
|
skillsCtx = field "skills" $ \item -> do
|
|
metadata <- getMetadata (itemIdentifier item)
|
|
let skills :: Maybe String
|
|
skills = case KeyMap.lookup (AK.fromString "skills") metadata of
|
|
Just (Array a) -> do
|
|
let
|
|
x = V.toList $ V.catMaybes $ fmap getName a
|
|
Just $ intercalate "<br/>" x
|
|
_ -> Just ("" :: String)
|
|
return $ fromMaybe "" skills
|
|
|
|
getName :: Value -> Maybe String
|
|
getName (Object v) = case KeyMap.lookup (AK.fromString "name") v of
|
|
Just (String x) -> Just (T.unpack x)
|
|
_ -> Nothing
|
|
getName _ = Nothing
|
|
|
|
priority :: MonadMetadata m => Item a -> m Int
|
|
priority i = do
|
|
mStr <- getMetadataField (itemIdentifier i) "priority"
|
|
return $ fromMaybe 0 (mStr >>= readMaybe)
|
|
|
|
byPriority :: MonadMetadata m => [Item a] -> m [Item a]
|
|
byPriority = sortByM priority
|
|
where
|
|
sortByM :: (Monad m, Ord k) => (a -> m k) -> [a] -> m [a]
|
|
sortByM f xs = map fst . sortBy (comparing snd) <$>
|
|
mapM (\x -> fmap (x,) (f x)) xs
|
|
|
|
niceRoute :: Routes
|
|
niceRoute = customRoute createIndexRoute
|
|
where createIndexRoute identifier =
|
|
takeDirectory p </> takeBaseName p </> "index.html"
|
|
where p = toFilePath identifier
|
|
|
|
rmIndexHtml :: Item String -> Compiler (Item String)
|
|
rmIndexHtml item = return $ fmap (withUrls rmIndexStr) item
|
|
|
|
rmIndexStr :: String -> String
|
|
rmIndexStr url = case splitFileName url of
|
|
(dir, "index.html") | isLocal dir -> dir
|
|
| otherwise -> url
|
|
_ -> url
|
|
where
|
|
isLocal :: String -> Bool
|
|
isLocal uri = not ("://" `isInfixOf` uri)
|
|
|
|
data Skill = Skill
|
|
{ skillName :: T.Text
|
|
, skillIntensity :: Float
|
|
}
|
|
deriving (Eq, Show, Generic)
|
|
|
|
instance FromJSON Skill where
|
|
-- fromYaml (Mapping yv _ ) = Skill <$> yv .: "name" <*> (read . T.unpack <$> yv .: "intensity")
|
|
-- fromYaml _ = error "bad input"
|
|
|
|
|
|
-- lookupStringList :: String -> Metadata -> Maybe [String]
|
|
-- lookupStringList key meta =
|
|
-- HMS.lookup (T.pack key) meta >>= Yaml.toList >>= mapM Yaml.toString
|
|
--
|
|
lookupStringList :: String -> Metadata -> Maybe [String]
|
|
lookupStringList key meta =
|
|
KeyMap.lookup (AK.fromString key) meta >>= yamlToList >>= mapM yamlToString
|
|
|
|
yamlToString :: Yaml.Value -> Maybe String
|
|
yamlToString (Yaml.String t) = Just (T.unpack t)
|
|
yamlToString (Yaml.Bool True) = Just "true"
|
|
yamlToString (Yaml.Bool False) = Just "false"
|
|
yamlToString (Yaml.Number d) | isInteger d = Just (formatScientific Fixed (Just 0) d)
|
|
| otherwise = Just (show d)
|
|
yamlToString _ = Nothing
|
|
|
|
yamlToList :: Yaml.Value -> Maybe [Yaml.Value]
|
|
yamlToList (Yaml.Array a) = Just (V.toList a)
|
|
yamlToList _ = Nothing
|
|
|