--  pi-hoole: lightweight access-control for pijul
--  Copyright (C) 2018 Thomas Letan <contact@thomasletan.fr>
--
--  This program is free software: you can redistribute it and/or modify
--  it under the terms of the GNU Affero General Public License as published
--  by the Free Software Foundation, either version 3 of the License, or
--  (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU Affero General Public License for more details.
--
--  You should have received a copy of the GNU Affero General Public License
--  along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}

module Main where

import           Control.Applicative           ((<|>))
import           Data.Aeson                    (FromJSON)
import           Data.ByteString.Base58        (bitcoinAlphabet, decodeBase58)
import           Data.ByteString.Lazy          (ByteString)
import           Data.Map.Strict               (Map, (!?))
import qualified Data.Map.Strict               as M (empty, foldlWithKey,
                                                     toList, traverseWithKey)
import           Data.Maybe                    (fromJust, fromMaybe, maybe)
import           Data.String                   (IsString, fromString)
import           Data.Text                     (Text, pack, unpack)
import           Data.Text.Encoding            (decodeUtf8)
import qualified Data.Text.Lazy                as TL (unpack)
import           Data.Yaml                     (decodeFile)
import           GHC.Generics                  (Generic)
import           Network.HTTP.Types.Method     (methodGet)
import           Network.HTTP.Types.Status     (status200, status404)
import           Network.Wai                   (Application, Request, pathInfo,
                                                requestMethod, responseLBS)
import           Network.Wai.Handler.Warp      (run)
import           PiHoole                       (Action (Log, Patch),
                                                Branch (..),
                                                Configuration (repositories),
                                                Pijul (..), Privilege,
                                                Repo (..), Role (Anon),
                                                fetchDescription, hasPrivileges,
                                                privilegeLe, recordPijul,
                                                requires)
import           System.Directory              (XdgDirectory (..),
                                                getXdgDirectory)
import           System.FilePath               (FilePath, (</>))
import           Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import           Text.Cassius                  (cassius, renderCss)
import           Text.Hamlet                   (HtmlUrl, hamlet)
import           Text.Regex.PCRE               ((=~))

main :: IO ()
main = do
  cfg <- getConfiguration
  web <- getWebSetting

  case (cfg, web) of
    (Just cfg, Just web) -> run 8080 (piHooleWeb web cfg)
    (Nothing, _) -> putStrLn "Could not open or parse pi-hoole configuration file"
    (_, Nothing) -> putStrLn "Could not open or parse pi-hoole-web configuration file"

  where piHooleWeb :: WebSetting -> Configuration -> Application
        piHooleWeb web cfg req respond =
          let action = requestToPijul req in
          if maybe False (pijulToPrivileges . repositories $ cfg) action
          then do res <- recordPijul (fromJust action)
                  respond $ responseLBS status200 [] (fromString res)
          else do
            page <- mapM (render web cfg) (requestToRoute req)
            respond $ maybe (responseLBS status404 [] "Sorry") (responseLBS status200 []) page

pijulToPrivileges :: Map Repo (Map Role Privilege) -> Pijul -> Bool
pijulToPrivileges cfg (Pijul repo action) =
  case cfg !? repo >>= (!? Anon) of
    Just priv -> requires action `privilegeLe` priv
    _         -> False

requestToPijul :: Request -> Maybe Pijul
requestToPijul req
  | isGet req = let path = pathInfo req
                in log path <|> patch path
  | otherwise = Nothing
  where
    log :: [Text] -> Maybe Pijul
    log = logAux ""

    logAux :: FilePath -> [Text] -> Maybe Pijul
    logAux path [".pijul", branch] = Pijul (Repo path) <$> (Log <$> parseBranch branch)
    logAux path (x:rst)  = logAux (path </> unpack x) rst
    logAux _ _ = Nothing

    parseBranch :: Text -> Maybe Branch
    parseBranch branch = case unpack branch =~ changesRegex of
      [[_, branch58]] -> Branch . decodeUtf8 <$> decodeBase58 bitcoinAlphabet (fromString branch58)
      _               -> Nothing

    changesRegex :: String
    changesRegex = "changes\\.(.*)$"

    patch :: [Text] -> Maybe Pijul
    patch = patchAux ""

    patchAux :: FilePath -> [Text] -> Maybe Pijul
    patchAux path [".pijul", "patches", patch] = Pijul (Repo path) <$> (Patch <$> parsePatch patch)
    patchAux path (x:rst)  = patchAux (path </> unpack x) rst
    patchAux _ _ = Nothing

    parsePatch :: Text -> Maybe Text
    parsePatch patch = case unpack patch =~ patchRegex of
      [[_, patch]] -> Just $ pack patch
      _            -> Nothing

    patchRegex :: String
    patchRegex = "(.*)\\.gz"

isGet :: Request -> Bool
isGet = (== methodGet) . requestMethod

getConfiguration :: IO (Maybe Configuration)
getConfiguration = getXdgDirectory XdgConfig "pi-hoole/config.yaml" >>= decodeFile

data Route = Home
           | Css

requestToRoute :: Request -> Maybe Route
requestToRoute req
  | isGet req = parseRequest (pathInfo req)
  | otherwise = Nothing
  where
    parseRequest []            = Just Home
    parseRequest ["style.css"] = Just Css
    parseRequest _             = Nothing

render :: WebSetting -> Configuration -> Route -> IO ByteString
render web conf Home = do
  repos <- M.traverseWithKey (\repo _ -> fetchDescription repo) (hasPrivileges Anon conf)

  pure . renderHtml $ renderHome web repos route
render _ _ Css = pure . fromString . TL.unpack $ renderCss $ [cassius|
html, body
  width: 100%
  height: 100%
  font-family: Arial
  color: #2e2e2e

a
  color: black

header, main
  width: 90%
  max-width: 800px
  margin: auto

main
  table
    margin-top: 3em
    margin-bottom: 3em
    border-spacing: 0
    max-width: 100%
    thead
      color: black

      td
        font-weight: bold
        border-bottom: 2px solid #f0f0f0
        text-align: center
        padding-top: 0.2em
        padding-bottom: 0.2em

    td
      padding-right: 2em
      padding-left: 2em

footer
  text-align: center
  font-size: 0.8em
|] route

renderHome :: WebSetting -> Map Repo (Maybe String) -> HtmlUrl Route
renderHome web repos = layout web [hamlet|
<table>
  <thead>
    <tr>
      <td>
        Name
      <td>
        Description
  <tbody>
    $forall (Repo repo, description) <- M.toList repos
      ^{renderRepo repo description}

    <p>
      You can clone these repositories, using the following command:

    <pre>
      <code>
        pijul clone #{baseUrl web </> "<Name>"}

    <p>
      For instance, you can clone <code>#{example web}</code>:

    <pre>
      <code>
        pijul clone #{baseUrl web </> example web}
|]
  where
    renderRepo :: FilePath -> Maybe String -> HtmlUrl Route
    renderRepo name description = [hamlet|
<tr>
  <td>
    #{name}
  <td>
    #{fromMaybe "" description}
|]

layout :: WebSetting -> HtmlUrl Route -> HtmlUrl Route
layout web content  = [hamlet|
<html lang="en">
  <head>
    <meta charset="utf-8">
    <link href="@{Css}" rel="stylesheet">
    <title>
      #{title web}
  <body>
    <header>
      <h1>
        <a href="@{Home}">
          #{title web}
    <main>
      ^{content}

    <footer>
      <p>
        Powered by
        <a href="https://lthms.xyz/blog/pi-hoole"><code>pi-hoole</code></a>.
|]

route :: Route -> [(Text, Text)] -> Text
route Home _ = ""
route Css _  = "style.css"

data WebSetting = WebSetting { title   :: Text
                             , baseUrl :: FilePath
                             , example :: FilePath
                             }
  deriving (Generic)

instance FromJSON WebSetting

getWebSetting :: IO (Maybe WebSetting)
getWebSetting = getXdgDirectory XdgConfig "pi-hoole/web.yaml" >>= decodeFile