fradrive-old/src/Settings/WellKnownFiles/TH.hs

module Settings.WellKnownFiles.TH
  ( mkWellKnown
  ) where

import ClassyPrelude.Yesod
import Utils

import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (Lift(..))
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))

import System.Directory.Tree

import qualified Data.ByteString as BS

import Utils.Lens.TH
import Control.Lens
import Data.Set.Lens

import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Char as Char (isAlphaNum, toUpper)

import qualified Data.Map as Map
import qualified Data.Set as Set

import Data.List.NonEmpty (NonEmpty(..))

import qualified Data.HashMap.Strict as HashMap

import qualified Data.HashSet as HashSet

import System.FilePath (splitDirectories, makeRelative)

import Settings.Mime

import Text.Blaze.Html (preEscapedToHtml)

import Control.Monad.Fail

nWellKnownFileName :: Name
nWellKnownFileName = mkName "WellKnownFileName"

nwellKnownFileNames :: Name
nwellKnownFileNames = mkName "wellKnownFileNames"

ngetWellKnownR :: Name
ngetWellKnownR = mkName "getWellKnownR"

nwellKnownHtmlLinks :: Name
nwellKnownHtmlLinks = mkName "wellKnownHtmlLinks"



mkWellKnown :: Lang -- ^ Default language
            -> FilePath -- ^ Base directory
            -> FilePath -- ^ Link file (@html_code.html@)
            -> DecsQ
mkWellKnown defLang wellKnownBase wellKnownLinks = do
  inputFiles <- fmap dirTree . liftIO $ readDirectoryWith (\f -> (f, ) <$> BS.readFile f) wellKnownBase

  mapM_ qAddDependentFile $ inputFiles ^.. folded . _1

  -- languageFiles :: Map Lang [(FilePath, ByteString)]
  languageFiles <- if
    | Dir{contents} <- inputFiles
      -> return . Map.fromList $ do
           (language, lContents) <- contents ^.. folded . $(multifocusL 2) _name id
           Dir{} <- pure lContents
           let
             lContents' :: [(FilePath, ByteString)]
             lContents' = flip mapMaybe (flattenDir lContents) $ \pFile -> do
               File{..} <- pure pFile
               guard $ name /= wellKnownLinks
               return $ file & _1 %~ makeRelative (wellKnownBase </> language)
           return (Text.pack language, lContents')
    | otherwise
      -> fail "wellKnownBase is not a directory"

  fLanguages <- if
    | defLang `Set.member` Map.keysSet languageFiles
    , let languages' = Set.delete defLang $ Map.keysSet languageFiles
      -> return $ defLang :| Set.toList languages'
    | otherwise
      -> fail "default language is missing in wellKnownBase"

   -- languageLinks :: Map Lang ByteString
  languageLinks <- if
    | Dir{contents} <- inputFiles
      -> return . Map.fromList $ do
           (language, lContents) <- contents ^.. folded . $(multifocusL 2) _name id
           Dir{} <- pure lContents
           let
             lContents' :: [ByteString]
             lContents' = flip mapMaybe (flattenDir lContents) $ \pFile -> do
               File{..} <- pure pFile
               guard $ name == wellKnownLinks
               return $ file ^. _2
           c <- lContents'
           return (Text.pack language, c)
    | otherwise
      -> fail "wellKnownBase is not a directory"

  lLanguages <- if
    | defLang `Set.member` Map.keysSet languageLinks
    , let languages' = Set.delete defLang $ Map.keysSet languageLinks
      -> return $ defLang :| Set.toList languages'
    | otherwise
      -> fail "default language is missing in wellKnownBase"


  fVar <- newName "f"
  hVar <- newName "h"
  lVar <- newName "l"

  let fileNames = setOf (folded . folded . _1) languageFiles
      fileContents = Map.fromListWith (<>) $ do
        (lang, fs) <- Map.toList languageFiles
        (fName, fContent) <- fs
        return ((fContent, mimeLookup $ Text.pack fName), Set.singleton (lang, fName))

      wellKnownFileName = dataD
        (cxt [])
        nWellKnownFileName
        []
        Nothing
        [ normalC (mkName $ fNameManip fName) []
          | fName <- Set.toList fileNames
        ]
        (pure $ derivClause Nothing [[t|Eq|], [t|Ord|], [t|Bounded|], [t|Enum|], [t|Read|], [t|Show|], [t|Generic|], [t|Typeable|]])
      wellKnownFileNameMapSig = sigD
        nwellKnownFileNames
        [t|HashMap [Text] $(conT nWellKnownFileName)|]
      wellKnownFileNameMap = funD
        nwellKnownFileNames
        [ clause [] (normalB $ [e|HashMap.fromList|] `appE` listE [ [e|($(TH.lift . map Text.pack $ splitDirectories fName), $(conE . mkName $ fNameManip fName))|] | fName <- Set.toList fileNames ]) []
        ]
      wellKnownFileNamePathMultiPiece = instanceD
        (cxt [])
        (conT ''PathMultiPiece `appT` conT nWellKnownFileName)
        [ funD 'toPathMultiPiece
          [ clause [conP (mkName $ fNameManip fName) []] (normalB . TH.lift . map Text.pack $ splitDirectories fName) []
            | fName <- Set.toList fileNames
          ]
        , funD 'fromPathMultiPiece
          [ clause [] (normalB [e|flip HashMap.lookup $(varE nwellKnownFileNames)|]) []
          ]
        ]
      wellKnownFileNameHashable = instanceD
        (cxt [])
        (conT ''Hashable `appT` conT nWellKnownFileName)
        []

      getWellKnownRSig = sigD
        ngetWellKnownR
        [t|forall m. MonadHandler m => $(conT nWellKnownFileName) -> m TypedContent|]
      getWellKnownR = funD
        ngetWellKnownR
        [ clause [varP fVar] (normalB [e|$(varE hVar) =<< selectLanguage fLanguages|])
          [ funD hVar $
            [ clause [varP lVar] (guardedB
                [ (,) <$> normalG [e|HashSet.member ($(varE lVar), $(varE fVar)) $ HashSet.fromList $(listE [ tupE [TH.lift l, conE . mkName $ fNameManip fName] | (l, fName) <- Set.toList xs ])|]
                      <*> [e|TypedContent mime (toContent fContent) <$ setEtag $(TH.lift $ hashToText (mime, fContent))|]
                ]) []
              | ((fContent, mime), xs) <- Map.toList fileContents
            ] ++ pure (clause [wildP] (normalB [e|notFound|]) [])
          ]
        ]

      wellKnownHtmlLinksSig = sigD
        nwellKnownHtmlLinks
        [t|forall m. MonadWidget m => m ()|]
      wellKnownHtmlLinks = funD
        nwellKnownHtmlLinks
        [ clause [] (normalB [e|toWidgetHead . preEscapedToHtml . $(varE hVar) =<< selectLanguage lLanguages|])
            [ sigD hVar [t|Text -> Text|]
            , funD hVar $
              [ clause [varP lVar] (guardedB
                  [ (,) <$> normalG [|$(varE lVar) == lang|]
                        <*> TH.lift (Text.filter (`notElem` ['\r', '\n']) $ Text.decodeUtf8 c)
                  ]) []
                | (lang, c) <- Map.toList languageLinks
              ] ++ pure (clause [wildP] (normalB [e|mempty|]) [])
            ]
        ]

  sequence
    [ wellKnownFileName, wellKnownFileNameMapSig, wellKnownFileNameMap, wellKnownFileNamePathMultiPiece, wellKnownFileNameHashable
    , getWellKnownRSig, getWellKnownR
    , wellKnownHtmlLinksSig, wellKnownHtmlLinks
    ]
  where
    fNameManip = Text.unpack . mconcat . over (traverse . _head) Char.toUpper . filter (not . null) . Text.split (not . isAlphaNum) . Text.pack