module Visual (build, Image(..)) where
import Data.Time (UTCTime)
import Data.List (isSuffixOf)
import qualified Config
import Common
import Templates (outerWith, loading_)
import Lucid
import Route
thumbWidth :: Int
thumbWidth = 710
data Image = Image
    { imgPath        :: FilePath
    , imgThumbPath   :: FilePath
    , imgThumbWidth  :: Int
    , imgThumbHeight :: Int
    , imgDate        :: UTCTime
    , imgNSFW        :: Bool     -- is the image nsfw?
    } deriving (Generic, Eq, Binary)
data EntryMeta = EntryMeta
    { title     :: Text
    , date      :: Text
    , updated   :: Maybe Text
    } deriving (Generic, Eq, FromJSON)
data Entry = Entry
    { entryTitle   :: Text
    , entryContent :: Text
    , entryItems   :: [Image]
    , entryDate    :: UTCTime
    , entryType    :: Text
    } deriving (Generic, Eq, Binary)
instance IsTimestamped Image where timestamp = imgDate
instance IsTimestamped Entry where timestamp = entryDate
build :: Task IO [Image]
build = do
    pictures <- match "visual/*" \src -> do
        path  <- copyFile src
        tpath <- callCommandWith (\a b -> "convert -resize 710x " <> a <> " " <> b)
                                 (-<.> "thumb.webp")
                                 src
        apath <- toAbsolute src
        size  <- read <$> readCommand "identify" ["-ping", "-format", "(%w, %h)", apath]
        let nsfw = "nsfw" `isSuffixOf` dropExtension src
        pure (Image path tpath thumbWidth (thumbHeight size) (timestamp src) nsfw)
    -- webcomics/albums
    entries <- matchDir "visual/*/" \src -> do
        matchFile "index.markdown" \src -> do
            (meta, doc) <- readPandocMetadata src
            renderPandoc doc
                <&> renderEntry meta
                >>= write (src -<.> "html")
        pure ()
    watch pictures do
        let sorted = filter (not . imgNSFW) $ recentFirst pictures
        match_ "./visual.rst" \src -> do
            intro <- compilePandoc src
            write "visual.html" $ renderVisual intro sorted
        return (take 4 sorted)
    where
        thumbHeight :: (Int, Int) -> Int
        thumbHeight (width, height) = round (fi height * fi thumbWidth / fi width)
        fi :: Int -> Float
        fi = fromIntegral
renderEntry :: EntryMeta -> Text -> Html ()
renderEntry meta content =
    outerWith def { Config.title = title meta
                  , Config.route = VEntryRoute
                  } do
        header_ do
            h1_ $ toHtml (title meta)
            p_ $ toHtml (date meta)
        toHtmlRaw content
        hr_ []
renderVisual :: Text -> [Image] -> Html ()
renderVisual txt imgs =
    outerWith def {Config.title = "visual"} do
        toHtmlRaw txt
        hr_ []
        section_ [class_ "visual"] $
            forM_ imgs \Image{..} ->
                figure_ $ a_ [href_ $ fromString imgPath] $ img_
                    [ src_ (fromString imgThumbPath)
                    , width_ (fromString $ show imgThumbWidth)
                    , height_ (fromString $ show imgThumbHeight)
                    , loading_ "lazy" ]

module Types where
import Common
data TitledPage = TitledPage
    { title       :: Text
    , description :: Maybe Text
    } deriving (Generic, Eq, FromJSON, Binary)

{-# LANGUAGE DuplicateRecordFields    #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE TypeSynonymInstances     #-}
{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE MultiParamTypeClasses    #-}
module Templates where
import Data.Time (UTCTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Time.LocalTime (zonedTimeToUTC)
import qualified Data.Map.Strict as Map
import Achille.Internal.IO (AchilleIO)
import Achille.Writable as Writable
import Lucid
import Lucid.Base (makeAttribute)
import Route
import Types
import Common
import Config
instance AchilleIO m => Writable m (Html a) where
    write to = Writable.write to . renderBS
showDate :: UTCTime -> String
showDate = formatTime defaultTimeLocale "%b %d, %_Y"
loading_ :: Text -> Attribute
loading_ = makeAttribute "loading"
property_ :: Text -> Attribute
property_ = makeAttribute "property"
toLink :: FilePath -> Html () -> Html ()
toLink url = a_ [ href_ (fromString $ "/" <> url) ]
logo :: Html ()
logo = toHtmlRaw ("<svg xmlns=\"http://www.w3.org/2000/svg\" version=\"1.1\" height=\"19px\" width=\"29px\"><path d=\"M 2,2 A 5,5 0 0 1 7,7 L 7, 12 A 5, 5 0 0 1 2,17 M 7,7 A 5,5 0 0 1 12,2 L 22,2 A 5,5 0 0 1 27,7 L 27,12 A 5, 5 0 0 1 22,17 L 12,17\" style=\"stroke-width: 2; stroke-linecap: butt; stroke-linejoin: bevel; stroke: #fff\" fill=\"none\"/></svg>" :: Text)
outer :: Html () -> Html ()
outer = outerWith def
outerWith :: SiteConfig -> Html () -> Html ()
outerWith SiteConfig{title,route,..} content = doctypehtml_ do
    head_ do
        meta_ [ name_ "viewport"
              , content_ "width=device-width, initial-scale=1.0, user-scalable=yes"
              ]
        meta_ [ name_ "theme-color",  content_ "#000000" ]
        meta_ [ name_ "robots", content_ "index, follow" ]
        meta_ [ charset_ "utf-8" ]
        link_ [ rel_ "stylesheet",  href_ "/assets/theme.css" ]
        link_ [ rel_  "shortcut icon"
              , type_ "image/svg"
              , href_ "/assets/favicon.svg"
              ]
        link_ [ rel_ "alternate"
              , type_ "application/atom+xml"
              , href_ "/atom.xml"
              ]
        meta_ [ property_ "og:title", content_ title ]
        meta_ [ property_ "og:type", content_ "website" ]
        meta_ [ property_ "og:image", content_ image ]
        meta_ [ property_ "og:description", content_ description ]
        title_ $ toHtml title
    body_ do
        header_ [ id_ "hd" ] $ section_ do
            a_ [ href_ "/" ] $ logo
            section_ $ nav_ do
                a_ [ href_ "/projects.html" ] "Projects"
                a_ [ href_ "/visual.html"   ] "Visual"
                a_ [ href_ "/readings.html" ] "Readings"
                a_ [ href_ "/quid.html"     ] "Quid"
        breadcrumb route
        main_ content
        footer_ [ id_ "ft" ] do
            "flupe 2020 · "
            a_ [ href_ "https://creativecommons.org/licenses/by-nc/2.0/" ]
                "CC BY-NC 2.0"
            " · "
            a_ [ href_ "https://instagram.com/ba.bou.m/", rel_ "me" ] "instagram"
            " · "
            a_ [ href_ "/atom.xml" ] "feed"

module Route (Route(..), link, breadcrumb) where
import Common
import Lucid
import Data.List (foldl')
data Route
    = IndexRoute
    | VisualRoute
    | PostRoute
    | ProjectsRoute
    | ProjectRoute Text
    | ProjectPageRoute Text Route
    | VEntryRoute
link :: Route -> Html ()
link route = a_ [href_ (path route)] (toHtml $ name route)
    where
        path IndexRoute             = "/"
        path ProjectsRoute          = "/projects.html"
        path VisualRoute            = "/visual.html"
        path PostRoute              = "/"
        path (ProjectRoute _)       = "/projects/"
        path (ProjectPageRoute _ _) = "/"
        path VEntryRoute            = "/"
        name IndexRoute             = "index"
        name ProjectsRoute          = "projects"
        name VisualRoute            = "visual"
        name PostRoute              = "post"
        name (ProjectRoute n)       = n
        name (ProjectPageRoute n r) = n
walk :: Route -> [Route]
walk IndexRoute             = []
walk VisualRoute            = []
walk PostRoute              = [IndexRoute]
walk ProjectsRoute          = []
walk (ProjectRoute _)       = [ProjectsRoute]
walk (ProjectPageRoute _ r) = walk r ++ [r]
walk (VEntryRoute)          = [VisualRoute]
breadcrumb :: Route -> Html ()
breadcrumb route =
    case walk route of
        [] -> mempty
        xs -> p_ [class_ "breadcrumb"] $
                  foldl' (\b r -> b <> sep <> link r) "∅" xs
    where sep = span_ [class_ "sep"] "←"

module Readings (build) where
import qualified Data.Yaml as Yaml
import Lucid
import Common
import Config
import Templates
data Book = Book
    { title     :: Text
    , author    :: Text
    , rating    :: Maybe Int
    } deriving (Generic, Show, FromJSON)
build :: Task IO FilePath
build = matchFile "readings.yaml" \p ->
    readBS p
        >>= (liftIO . Yaml.decodeThrow)
        <&> renderReadings
        >>= write (p -<.> "html")
renderReadings :: [Book] -> Html ()
renderReadings books =
    outerWith def { Config.title       = "readings"
                  , Config.description = "books I've read"
                  } do
        table_ [ class_ "books" ] $
            forM_ books \Book {title, author, rating} ->
                tr_ do
                    td_ (toHtml title)
                    td_ (toHtml author)
                    td_ (toHtml $ fromMaybe "." $ flip replicate '★' <$> rating)

module Projects (build) where
import Lucid
import Data.Char (digitToInt)
import qualified Data.Map.Strict as Map
import Common
import Route
import Types
import Config
import Templates
data Project = Project 
    { title    :: Text
    , subtitle :: Text
    , year     :: Text
    , labels   :: Map.Map Text Text
    } deriving (Generic, Eq, FromJSON, Binary)
build :: Task IO ()
build = do
    projects <- matchDir "projects/*/" buildProject
    watch projects $ match_ "./projects.rst" \src -> do
        intro <- compilePandocWith def wopts src
        write "projects.html" (renderIndex intro projects)
buildProject :: FilePath -> Task IO (Project, FilePath)
buildProject src = do
    match "*" copyFile
    name     <- takeBaseName <$> getCurrentDir
    children <- buildChildren name
    watch children $ matchFile "index.*" \src -> do
        (meta, doc) <- readPandocMetadataWith ropts src
        renderPandocWith wopts doc
            <&> renderProject meta children
            >>= write (src -<.> "html")
        (meta,) <$> getCurrentDir
    where
        buildChildren :: String -> Task IO [(Text, FilePath)]
        buildChildren name = match "pages/*" \filepath -> do
            let (key, file) = getKey $ takeFileName filepath
            (TitledPage title _, doc) <- readPandocMetadataWith ropts filepath
            renderPandocWith wopts doc
                <&> toHtmlRaw
                <&> outerWith (def { Config.title = title
                                   , Config.route = ProjectPageRoute title (ProjectRoute $ fromString name)
                                   })
                >>= write (filepath -<.> "html")
                <&> (title,)
renderProject :: Project -> [(Text, FilePath)] -> Text -> Html ()
renderProject Project{..} children content =
    outerWith def { Config.title       = title
                  , Config.description = subtitle
                  , Config.route       = ProjectRoute title
                  } do
        header_ [class_ "project"] do
            div_ (img_ [src_ "logo.svg"])
            div_ do
                h1_ (toHtml title)
                p_  (toHtml subtitle)
                ul_ $ forM_ (Map.toList labels) \(k, v) -> li_ do
                    toHtml k <> ": "
                    if k == "repo" then
                        a_ [href_ $ "https://github.com/" <> v]
                            $ toHtml v
                    else toHtml v
        when (length children > 0) $
            ol_ [class_ "pages"] $ forM_ children \(title, path) ->
                li_ $ a_ [href_ (fromString path)] (toHtml title)
        toHtmlRaw content
renderIndex :: Text -> [(Project, FilePath)] -> Html ()
renderIndex intro projects =
    outerWith def { Config.title = "projects"
                  , Config.description = intro
                  } do
        toHtmlRaw intro
        ul_ [class_ "projects"] $ forM_ projects projectLink
    where
        projectLink :: (Project, FilePath) -> Html ()
        projectLink (Project{..}, path) =
            li_ $ a_ [href_ (fromString path)] do
                div_ $ img_ [src_ (fromString $ path </> "logo.svg")]
                div_ $ h2_ (toHtml title) >> p_  (toHtml subtitle)
getKey :: String -> (Int, String)
getKey xs = getKey' 0 xs
    where
        getKey' :: Int -> String -> (Int, String)
        getKey' k (x : xs) | x >= '0' && x <= '9' =
            getKey' (k * 10 +  digitToInt x) xs
        getKey' k ('-' : xs) = (k, xs)
        getKey' k xs         = (k, xs)

module Posts where
import Data.Aeson.Types (FromJSON)
import Data.Binary      (Binary, put, get)
import Data.Time        (UTCTime, defaultTimeLocale)
import Data.Time.Clock  (getCurrentTime)
import Data.Time.Format (rfc822DateFormat, formatTime)
import Data.List        (isPrefixOf)
import GHC.Generics
import Lucid
import Text.Atom.Feed   as Atom
import Text.Feed.Types  (Feed(..))
import Text.Feed.Export (textFeed)
import qualified Achille.Internal.IO as AchilleIO
import Common
import Config (ropts, wopts)
import Visual (Image(..))
import qualified Config
import Templates
import Route
import System.FilePath
import System.Directory ( setCurrentDirectory
                        , getTemporaryDirectory
                        , renameDirectory
                        , createDirectoryIfMissing
                        )
--  metadata used for parsing YAML headers
data PostMeta = PostMeta
    { title       :: Text
    , draft       :: Maybe Bool
    , description :: Maybe Text
    } deriving (Generic, Eq, Show, FromJSON)
data Post = Post
    { postTitle       :: Text
    , postDate        :: UTCTime
    , postDraft       :: Bool
    , postDescription :: Maybe Text
    , postContent     :: Text
    , postPath        :: FilePath
    } deriving (Generic, Eq, Show, Binary)
instance IsTimestamped Post where timestamp = postDate
buildPost :: FilePath -> Task IO Post
buildPost src = do
    copyFile src
    let ext = takeExtensions src
    if ".lagda.md" `isPrefixOf` ext then processAgda src
    else do
        (PostMeta title draft desc, pandoc) <- readPandocMetadataWith ropts src
        content <- renderPandocWith wopts pandoc
        let date = timestamp src
        pure (renderPost date title content)
            >>= write (src -<.> "html")
            <&> Post title date (fromMaybe False draft) Nothing content
    where
        processAgda :: FilePath -> Task IO Post
        processAgda src = do
            spath  <- toAbsolute src
            odir   <- getOutputDir <&> (</> dropExtensions src)
            tmpdir <- liftIO getTemporaryDirectory <&> (</> "achille")
            liftIO $ createDirectoryIfMissing False tmpdir
            liftIO $ createDirectoryIfMissing False odir
            liftIO $ AchilleIO.copyFile spath (tmpdir </> "index.lagda.md")
            -- agda --html needs to be invoked in the correct directory
            liftIO $ setCurrentDirectory tmpdir
            callCommand $
                "agda --html "
                <> "--html-dir=. "
                <> "--html-highlight=auto "
                <> "index.lagda.md"
            callCommand $ "cp " <> tmpdir <> "/* " <> odir
            let tpath = odir </> "index.md"
            (PostMeta title draft desc, pandoc) <- readAbsPandocMetadataWith ropts tpath
            content <- renderPandocWith wopts pandoc
            let date = timestamp src
            pure (renderPost date title content)
                >>= write (dropExtensions src </> "index.html")
                <&> takeDirectory
                <&> Post title date (fromMaybe False draft) Nothing content
build :: Bool -> [Image] -> Task IO ()
build showDrafts imgs = do
    posts <- match "posts/*" buildPost
             <&> filter (\p -> not (postDraft p) || showDrafts)
             <&> recentFirst
    watch imgs $ watch posts $ match_ "index.rst" \src -> do
        compilePandoc src
            <&> renderIndex imgs posts
            >>= write (src -<.> "html")
        now <- liftIO getCurrentTime
        let (Just feed) = textFeed (AtomFeed $ postsToFeed now posts)
        write "atom.xml" feed
    where
        postsToFeed now posts =
            ( Atom.nullFeed
                "https://acatalepsie.fr/atom.xml"
                (Atom.TextString "acatalepsie")
                "2017-08-01")
            { Atom.feedEntries = postToEntry <$> posts
            , Atom.feedUpdated = fromString $ toDate now
            }
        postToEntry :: Post -> Atom.Entry
        postToEntry post =
            ( Atom.nullEntry (fromString $ postPath post)
                             (Atom.TextString $ postTitle post)
                             (fromString $ toDate $ postDate post))
            { Atom.entryContent = Just $ Atom.HTMLContent $ postContent post
            , Atom.entrySummary = Atom.HTMLString <$> postDescription post
            }
renderPost :: UTCTime -> Text -> Text -> Html ()
renderPost date title content =
    outerWith def { Config.title = title, Config.route = PostRoute } do
        header_ do
            h1_ $ toHtml title
            p_ do
                "Posted on "
                time_ $ toHtml (showDate date)
                "."
        toHtmlRaw content
renderIndex :: [Image] -> [Post] -> Text -> Html ()
renderIndex imgs posts content = 
    outer do
        toHtmlRaw content
        section_ [class_ "visual tiny"] $
            forM_ imgs \Image{..} ->
                figure_ $ a_ [href_ $ fromString imgPath] $ img_
                    [ src_ (fromString imgThumbPath)
                    , width_ (fromString $ show imgThumbWidth)
                    , height_ (fromString $ show imgThumbHeight)
                    ]
        p_ [class_ "right"] $ a_ [href_ "/visual.html"] "→ View more visual work"
        h2_ "Latest posts"
        ul_ [ id_ "pidx" ] $ forM_ posts \post ->
            li_ do
                span_ $ fromString $ showDate (postDate post)
                toLink (postPath post) (toHtml $ postTitle post)

{-# LANGUAGE LambdaCase #-}
module Main where
import qualified System.Process as Process
import System.Directory        (removePathForcibly)
import Control.Monad           (void, mapM_)
import Options.Applicative
import Lucid
import Common
import Templates
import Config (config, ropts, wopts, SiteConfig(title))
import qualified Posts
import qualified Projects
import qualified Visual
import qualified Readings
type ShowDrafts = Bool
data Cmd
    = Build ShowDrafts -- ^ Build the site
    | Deploy           -- ^ Deploy to the server
    | Clean            -- ^ Delete all artefacts
    deriving (Eq, Show)
cli :: Parser Cmd
cli = hsubparser $
      command "build"  (info (Build <$> switch (long "draft" <> short 'D' <> help "Display drafts"))
                             (progDesc "Build the site once" ))
   <> command "deploy" (info (pure Deploy) (progDesc "Server go brrr"      ))
   <> command "clean"  (info (pure Clean)  (progDesc "Delete all artefacts"))
main :: IO ()
main = customExecParser p opts >>= \case
    Deploy -> mapM_ Process.callCommand (deployCmd config)
    Clean  -> removePathForcibly        (outputDir config)
           >> removePathForcibly        (cacheFile config)
    Build showDrafts -> void $ runTask [] config (build showDrafts)
    where
        opts = info (cli <**> helper) $ fullDesc <> header desc
        p    = prefs showHelpOnEmpty
        desc = "acatalepsie & co"
build :: ShowDrafts -> Task IO String
build showDrafts = do
    -- static assets
    match_ "assets/*" copyFile
    match_ "static/*" copyFile
    -- quid page
    match_ "./quid.rst" \src ->
        compilePandoc src
        <&> toHtmlRaw
        <&> outerWith def {Config.title = "quid"}
        >>= write (src -<.> "html")
    lastImages <- Visual.build
    Projects.build
    Posts.build showDrafts lastImages
    Readings.build

module Config (config, ropts, wopts, SiteConfig(..), def) where
import Data.Default
import Data.Text (Text)
import Text.Pandoc.Options as Pandoc
import Achille (Config(..))
import Route
config :: Achille.Config
config = def
    { deployCmd  = Just "rsync -avzzr ~/dev/acatalepsie/_site/ --chmod=755 acatalepsie:/var/www/html"
    , contentDir = root <> "content"
    , outputDir  = root <> "_site"
    , cacheFile  = root <> ".cache"
    , ignore     = [ "**/*.agdai"
                   , "**/*~"
                   ]
    } where root = "/home/flupe/dev/acatalepsie/"
ropts :: Pandoc.ReaderOptions
ropts = def { readerExtensions = pandocExtensions }
wopts :: Pandoc.WriterOptions
wopts = def { writerHTMLMathMethod = KaTeX "" }
data SiteConfig = SiteConfig
    { title       :: Text
    , description :: Text
    , image       :: Text
    , route       :: Route
    }
instance Default SiteConfig where
    def = SiteConfig
        { title       = "sbbls"
        , description = "my personal web space, for your enjoyment"
        , image       = "https://acatalepsie.fr/assets/card.png"
        , route       = IndexRoute
        }

module Common
    ( module Data.Functor
    , module Data.Sort
    , module Data.String
    , module System.FilePath
    , module Achille
    , module Achille.Task.Pandoc
    , module Data.Text
    , module Control.Monad
    , module Data.Maybe
    , module Lucid
    , module Data.Binary
    , module GHC.Generics
    , module Data.Aeson.Types
    , toDate
    ) where
import Achille
import Achille.Task.Pandoc
import Data.Time        (UTCTime, defaultTimeLocale, formatTime, rfc822DateFormat)
import Data.Aeson.Types (FromJSON)
import GHC.Generics     (Generic)
import Data.Binary      (Binary)
import Data.Functor     ((<&>))
import Control.Monad    (forM_, when)
import Data.Sort        (sort)
import Data.String      (fromString)
import Data.Text        (Text)
import Data.Maybe       (fromMaybe, mapMaybe)
import System.FilePath
import Lucid            (Html)
toDate :: UTCTime -> String
toDate = formatTime defaultTimeLocale rfc822DateFormat

cabal-version:       >=1.10
name:                site
version:             0.1.0.0
author:              flupe
maintainer:          lucas@escot.me
build-type:          Simple
executable site
  main-is:             Main.hs
  hs-source-dirs:      src
  other-modules:       Templates
                     , Types
                     , Posts
                     , Projects
                     , Common
                     , Config
                     , Visual
                     , Templates
                     , Readings
                     , Route
  build-depends:       base >= 4.12 && < 5
                     , filepath
                     , achille
                     , data-default
                     , pandoc
                     , pandoc-types
                     , text
                     , bytestring
                     , filepath
                     , aeson
                     , yaml
                     , binary
                     , containers
                     , sort
                     , feed
                     , time
                     , lucid
                     , optparse-applicative
                     , process
                     , directory
  default-extensions:   BlockArguments
                      , TupleSections
                      , OverloadedStrings
                      , ScopedTypeVariables
                      , DeriveGeneric
                      , DeriveAnyClass
                      , RecordWildCards
                      , NamedFieldPuns
  ghc-options:       -threaded
                     -j8
  default-language:    Haskell2010

This site is under construction, please be kind.
-----
All content on this website is licensed under `CC BY-NC 2.0`_ unless stated
otherwise. In other words, you are free to copy, redistribute and edit this
content, provided you: give appropriate credit; indicate where changes were made
and do not do so for commercial purposes.
This website is hosted on a 2014 RPi Model B+ somewhere in France.
The domain name `acatalepsie.fr <https://acatalepsie.fr>`_ has
been registered at `gandi.net <https://gandi.net>`_.
.. _CC BY-NC 2.0: https://creativecommons.org/licenses/by-nc/2.0/

packages: ../achille/achille.cabal site.cabal
jobs: 8

my personal website, made with [achille](https://acatalepsie.fr/projects/achille).
```
nix-shell --attr env release.nix
nix-env -if release.nix
```
## todo
- dark theme
- faster thumbnail generation with openCV
- generic feed generation
- indieweb interactions (webmentions, etc)
- bin packing / grid system for galery
- better gallery (albums, webzines, media types, layouts, etc)
- tag/category/search engine
- parallelization
- draft builds + live server