{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}

module Server ( loadConfig
              , Org(..)
              , Sha1
              , Config, tmpdir, port, verbose, orgs, interval, exneuland, token
              , RemoteRef(..)
              , ServerState, emptyState, unState
              , JobStatus(..)
              , setJobStatus
              , prettySha,getJobStatus) where

import           Universum

import           CheckDir                   (DirResult)
import           Control.Arrow              ((>>>))
import           Control.Concurrent         (modifyMVar_, withMVar)
import           Crypto.Hash.SHA1           (hash)
import           Data.Aeson                 (FromJSON, ToJSON, ToJSONKey (..),
                                             eitherDecodeFileStrict')
import qualified Data.Aeson                 as A
import qualified Data.ByteString.Base64.URL as Base64
import           Data.Coerce                (coerce)
import           Data.Either.Extra          (mapLeft)
import           Data.Functor.Contravariant (contramap)
import qualified Data.Map                   as M
import           Lens.Micro.Platform        (at, ix, makeLenses, traverseOf)
import           LintConfig                 (LintConfig')
import           Servant                    (FromHttpApiData)
import           Servant.Client             (BaseUrl, parseBaseUrl)
import           Toml                       (BiMap (BiMap), TomlBiMap,
                                             TomlBiMapError (ArbitraryError),
                                             TomlCodec, prettyTomlDecodeErrors,
                                             (.=))
import qualified Toml                       as T

-- | a reference in a remote git repository
data RemoteRef = RemoteRef
  { repourl  :: Text
  , reporef  :: Text
  , reponame :: Text
  -- ^ the "world name" for the hub / world:// links
  } deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show)

type family ConfigRes (b :: Bool) a where
  ConfigRes True a = a
  ConfigRes False a = FilePath

-- | the internal text is actually already base64-encoded
newtype Sha1 = Sha1 Text
  deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON)

-- | base64-encoded sha1
prettySha :: Sha1 -> Text
prettySha (Sha1 text) = text

instance ToJSONKey Sha1

toSha :: RemoteRef -> Sha1
toSha ref = Sha1
  . decodeUtf8
  . Base64.encode
  . hash
  . encodeUtf8
  $ (show ref :: Text)

data Org (loaded :: Bool) = Org
  { orgSlug       :: Text
  , orgLintconfig :: ConfigRes loaded LintConfig'
  , orgEntrypoint :: FilePath
  , orgRepos      :: [RemoteRef]
  , orgUrl        :: Text
  , orgWebdir     :: Text
  } deriving Generic

-- | Orgs are compared via their slugs only
-- TODO: the server should probably refuse to start if two orgs have the
-- same slug … (or really the toml format shouldn't allow that syntactically)
instance Eq (Org True) where
  a == b = orgSlug a == orgSlug b

instance Ord (Org True) where
  a <= b = orgSlug a <= orgSlug b

-- this instance exists since it's required for ToJSONKey,
-- but it shouldn't really be used
instance ToJSON (Org True) where
  toJSON Org { .. } = A.object [ "slug" A..= orgSlug ]

-- orgs used as keys just reduce to their slug
instance ToJSONKey (Org True) where
  toJSONKey = contramap orgSlug (toJSONKey @Text)

-- | the server's configuration
data Config (loaded :: Bool) = Config
  { _tmpdir    :: FilePath
  -- ^ dir to clone git things in
  , _port      :: Int
  , _verbose   :: Bool
  , _interval  :: Int
  -- ^ port to bind to
  , _exneuland :: BaseUrl
  , _token     :: Maybe Text
  , _orgs      :: [Org loaded]
  } deriving Generic

makeLenses ''Config


remoteCodec :: TomlCodec RemoteRef
remoteCodec = RemoteRef
  <$> T.text "url" .= repourl
  <*> T.text "ref" .= reporef
  <*> T.text "name" .= reponame

orgCodec :: TomlCodec (Org False)
orgCodec = Org
  <$> T.text "slug" .= orgSlug
  <*> T.string "lintconfig" .= orgLintconfig
  <*> T.string "entrypoint" .= orgEntrypoint
  <*> T.list remoteCodec "repo" .= orgRepos
  <*> T.text "url" .= orgUrl
  <*> T.text "webdir" .= orgWebdir

-- why exactly does everything in tomland need to be invertable
urlBimap :: TomlBiMap BaseUrl String
urlBimap = BiMap
  (Right . show)
  (mapLeft (ArbitraryError . show) . parseBaseUrl)

configCodec :: TomlCodec (Config False)
configCodec = Config
    <$> T.string "tmpdir" .= _tmpdir
    <*> T.int "port" .= _port
    <*> T.bool "verbose" .= _verbose
    <*> T.int "interval" .= _interval
    <*> T.match (urlBimap >>> T._String) "exneuland" .= _exneuland
    -- First is just Maybe but with different semantics
    <*> coerce (T.first T.text "token") .= _token
    <*> T.list orgCodec "org" .= _orgs

-- | a job status (of a specific uuid)
data JobStatus =
  Pending | Linted DirResult Text | Failed Text
  deriving (Generic, ToJSON)

-- | the server's global state; might eventually end up with more
-- stuff in here, hence the newtype
newtype ServerState = ServerState
  { _unState :: Map (Org True) (Map Sha1 (RemoteRef, JobStatus)) }

makeLenses ''ServerState

-- | the inital state must already contain empty orgs, since setJobStatus
-- will default to a noop otherwise
emptyState :: Config True -> ServerState
emptyState config = ServerState
  $ M.fromList $ map (, mempty) (view orgs config)

-- | loads a config, along with all things linked in it
-- (e.g. linterconfigs for each org)
loadConfig :: FilePath -> IO (Config True)
loadConfig path = do
  res <- T.decodeFileEither configCodec path
  case res of
    Right config -> traverseOf orgs (mapM loadOrg) config
    Left err     -> error $ prettyTomlDecodeErrors err
    where
      loadOrg :: Org False -> IO (Org True)
      loadOrg org = do
        lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case
          Right c  -> pure c
          Left err -> error $ show err
        pure $ org { orgLintconfig = lintconfig }


-- | NOTE: this does not create the org if it does not yet exist!
setJobStatus :: MVar ServerState -> Org True -> RemoteRef -> JobStatus -> IO ()
setJobStatus mvar !org !ref !status = modifyMVar_ mvar
  $ pure . over (unState . ix org . at (toSha ref)) (const $ Just (ref, status))

getJobStatus :: MVar ServerState -> Text -> Sha1 -> IO (Maybe (RemoteRef, JobStatus))
getJobStatus mvar orgslug sha = withMVar mvar $ \state ->
  pure (M.lookup sha (view (unState . ix (Org { orgSlug = orgslug })) state))