Language.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DuplicateRecordFields #-}


module Glot.Language
    ( Id
    , idToText
    , idFromText
    , EditorConfig(..)
    , RunConfig(..)
    , Language(..)
    , Book(..)
    , readLanguages
    , isRunnable
    , find
    ) where

import Prelude hiding (id)
import qualified Dhall
import qualified Dhall.TH
import qualified Yesod.Static as Static
import qualified Yesod.Core.Dispatch as Dispatch
import qualified Data.Text as Text
import qualified Data.Text.IO as TextIO
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Aeson as Aeson
import qualified GHC.Generics as GHC
import qualified Database.Persist.Sql as Sql
import qualified Data.Either.Combinators as Either
import qualified Data.Either as Either
import qualified Control.Exception as Exception


Dhall.TH.makeHaskellTypes
    [ Dhall.TH.SingleConstructor "EditorConfig" "EditorConfig" "./config/types/EditorConfig.dhall"
    , Dhall.TH.SingleConstructor "RunConfig" "RunConfig" "./config/types/RunConfig.dhall"
    , Dhall.TH.SingleConstructor "Book" "Book" "./config/types/Book.dhall"
    , Dhall.TH.SingleConstructor "LanguageConfig" "LanguageConfig" "./config/types/Language.dhall"
    ]

deriving instance Show EditorConfig

deriving instance Show RunConfig

deriving instance Show Book

deriving instance Show LanguageConfig




newtype Id = Id Text.Text
    deriving (Show, Read, Eq, Ord, GHC.Generic)
    deriving newtype (Aeson.ToJSON, Sql.PersistField, Sql.PersistFieldSql)


instance Aeson.FromJSON Id where
    parseJSON = Aeson.withText "Language.Id" $ \text ->
        case idFromText text of
            Just id ->
                pure id

            Nothing ->
                Prelude.fail "Not a valid language id"


instance Dispatch.PathPiece Id where
    fromPathPiece text =
        idFromText text

    toPathPiece id =
        idToText id



idToText :: Id -> Text.Text
idToText (Id id) =
    id


idFromText :: Text.Text -> Maybe Id
idFromText text =
    if isValidId text then
        Just (Id text)

    else
        Nothing



data Language = Language
    { identifier :: Id
    , name :: Text.Text
    , svgLogoRoute :: Static.StaticRoute
    , pngLogoRoute :: Static.StaticRoute
    , fileExtension :: Text.Text
    , editorConfig :: EditorConfig
    , runConfig :: Maybe RunConfig
    , books :: [Book]
    }
    deriving (Show)



readLanguages :: IO [Language]
readLanguages = do
    langConfigs <- Dhall.input Dhall.auto "./config/languages.dhall"
    eitherLanguages <- mapM fromConfigIO langConfigs
    let (errors, languages) = Either.partitionEithers eitherLanguages
    mapM_ (\err -> TextIO.putStrLn $ "WARNING: " <> err) (map formatConfigError errors)
    pure languages


data ConfigError
    = InvalidId LanguageConfig
    | FailedToReadLogo LanguageConfig Exception.SomeException


formatConfigError :: ConfigError -> Text.Text
formatConfigError err =
    case err of
        InvalidId LanguageConfig{..} ->
            mconcat
                [ "Language "
                , id
                , " does not have a valid id. The id can only contain lowercase characters and digits."
                ]


        FailedToReadLogo LanguageConfig{..} exception ->
            mconcat
                [ "Failed to read logos for language "
                , id
                , ", exception: "
                , Text.pack (show exception)
                ]


fromConfigIO :: LanguageConfig -> IO (Either ConfigError Language)
fromConfigIO langConfig = do
    eitherLogoEtags <- Exception.try (readLogoEtags langConfig)
    case eitherLogoEtags of
        Left exception ->
            pure $ Left (FailedToReadLogo langConfig exception)

        Right logoEtags ->
            pure (fromConfig langConfig logoEtags)


fromConfig :: LanguageConfig -> LogoEtags -> Either ConfigError Language
fromConfig langConfig@LanguageConfig{..} LogoEtags{..} =
    let
        svgLogoRoute =
            Static.StaticRoute ["img", logoName <> ".svg"] [("etag", svgEtag)]

        pngLogoRoute =
            Static.StaticRoute ["img", logoName <> ".svg.png"] [("etag", pngEtag)]
    in do
    identifier <- Either.maybeToRight (InvalidId langConfig) (idFromText id)
    pure Language{..}



isRunnable :: Language -> Bool
isRunnable Language{..} =
    Maybe.isJust runConfig


find :: [Language] -> Id -> Maybe Language
find languages langId =
    List.find (\lang -> identifier lang == langId) languages


-- TODO: get static root from arg
svgLogoPath :: LanguageConfig -> Text.Text
svgLogoPath LanguageConfig{..} =
    Text.intercalate "/" ["static", "img", logoName <> ".svg"]


-- TODO: get static root from arg
pngLogoPath :: LanguageConfig -> Text.Text
pngLogoPath LanguageConfig{..} =
    Text.intercalate "/" ["static", "img", logoName <> ".svg.png"]


isValidId :: Text.Text -> Bool
isValidId text =
    let
        allowedChars =
            ['a'..'z'] ++ ['0'..'9']

        hasOnlyAllowedChars =
            Text.all (`elem` allowedChars) text

        hasMinimumLength =
            Text.length text > 0
    in
    hasMinimumLength && hasOnlyAllowedChars


data LogoEtags = LogoEtags
    { svgEtag :: Text.Text
    , pngEtag :: Text.Text
    }


readLogoEtags :: LanguageConfig -> IO LogoEtags
readLogoEtags langConfig = do
    svgEtag <- readEtag (svgLogoPath langConfig)
    pngEtag <- readEtag (pngLogoPath langConfig)
    pure LogoEtags
        { svgEtag = Text.pack svgEtag
        , pngEtag = Text.pack pngEtag
        }


readEtag :: Text.Text -> IO String
readEtag path = do
    bytes <- BS.readFile (Text.unpack path)
    pure $ Static.base64md5 (BSL.fromStrict bytes)