path: root/server/Server.hs

{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TupleSections        #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

module Server ( loadConfig
              , Org(..)
              , Sha1, toSha
              , Config, tmpdir, port, verbose, orgs, interval, exneuland, token
              , CliOptions(..)
              , OfflineException
              , RemoteRef(..)
              , ServerState, emptyState, unState
              , JobStatus(..)
              , prettySha,getJobStatus,overJobStatus
              , adjustedPath,RealtimeMsg(..),newRealtimeChannel,adjustedWebPath) where

import           Universum                    hiding (_2, view, (%~))

import           CheckDir                     (DirResult)
import           CheckMap                     (ResultKind (Shrunk))
import           Control.Arrow                ((>>>))
import           Control.Concurrent           (modifyMVar, withMVar)
import           Control.Concurrent.STM.TChan (TChan, newBroadcastTChan)
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.Strict              as M
import           Lens.Micro.Platform          (_2, at, ix, makeLenses,
                                               traverseOf, view, (%~))
import           LintConfig                   (ConfigKind (..), LintConfig,
                                               feedConfig)
import           Servant                      (FromHttpApiData)
import           Servant.Client               (BaseUrl, parseBaseUrl)
import qualified Text.Show                    as TS
import qualified Toml                         as T
import           Toml                         (BiMap (BiMap), TomlBiMap,
                                               TomlBiMapError (ArbitraryError),
                                               TomlCodec,
                                               prettyTomlDecodeErrors, (.=))
import           WithCli                      (HasArguments)

-- | 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, NFData)

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, NFData)

-- | 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 Skeleton)
  , orgEntrypoint     :: FilePath
  , orgGeneration     :: Int
  , orgRepos          :: [RemoteRef]
  , orgUrl            :: Text
  , orgWebdir         :: Text
  , orgHumanWebdir    :: Text
  , orgBacklinkPrefix :: Text
  , orgContactMail    :: Text
  , orgHowtoLink      :: Maybe Text
  } deriving (Generic)

instance NFData (LintConfig Skeleton) => NFData (Org True)
deriving instance Show (LintConfig Skeleton) => Show (Org True)

-- | 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 :: Maybe BaseUrl
  , _token     :: Maybe Text
  , _orgs      :: [Org loaded]
  } deriving Generic

makeLenses ''Config

data CliOptions = CliOptions
  { offline :: Bool
  , config  :: Maybe FilePath
  } deriving (Show, Generic, HasArguments)

data OfflineException = OfflineException
  deriving (Show, Exception)

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.int "generation" .= orgGeneration
  <*> T.list remoteCodec "repo" .= orgRepos
  <*> T.text "url" .= orgUrl
  <*> T.text "webdir" .= orgWebdir
  <*> T.text "webdir_human" .= orgHumanWebdir
  <*> T.text "backlink_prefix" .= orgBacklinkPrefix
  <*> T.text "contact_mail" .= orgContactMail
  <*> coerce (T.first T.text "howto_link") .= orgHowtoLink

-- 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
    <*> coerce (T.first (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

-- | 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@Org{..} = do
        lintconfig <-
          eitherDecodeFileStrict' orgLintconfig >>= \case
          Right (c :: LintConfig Basic) -> pure c
          Left err                      -> error $ show err
        pure $ org { orgLintconfig =
                     feedConfig lintconfig (map reponame orgRepos) orgSlug }

data RealtimeMsg = RelintPending | Reload
  deriving (Generic, ToJSON)

type RealtimeChannel = TChan RealtimeMsg

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

instance TS.Show JobStatus where
  show = \case
    Pending _    -> "Pending"
    Linted _ _ _ -> "Linted result"
    Failed err   -> "Failed with: " <> show err

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

-- instance NFData LintConfig' => NFData ServerState

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 (\org -> (orgSlug org, (org, mempty))) (view orgs config)

-- | NOTE: this does not create the org if it does not yet exist!
overJobStatus
  :: MVar ServerState
  -> Org True
  -> RemoteRef
  -> (Maybe (RemoteRef, JobStatus, Maybe JobStatus) ->
      Maybe (RemoteRef, JobStatus, Maybe JobStatus))
  -> IO (Maybe (RemoteRef, JobStatus, Maybe JobStatus))
overJobStatus mvar !org !ref overState = do
  modifyMVar mvar $ \state -> do
    -- will otherwise cause a thunk leak, since Data.Map is annoyingly un-strict
    -- even in its strict variety. for some reason it also doesn't work when
    -- moved inside the `over` though …
    bla <- evaluateWHNF (view (unState . ix (orgSlug org) . _2) state)
    let thing = state & (unState . ix (orgSlug org) . _2 .  at (toSha ref)) %~ overState
    pure (thing, view (at (toSha ref)) bla)


getJobStatus
  :: MVar ServerState
  -> Text
  -> Sha1
  -> IO (Maybe (Org True, RemoteRef, JobStatus, Maybe JobStatus))
getJobStatus mvar orgslug sha = withMVar mvar $ \state -> pure $ do
  (org, jobs) <- view (unState . at orgslug) state
  (ref, status, rev) <- M.lookup sha jobs
  Just (org, ref, status, rev)


-- | the path (relative to a baseurl / webdir) where an adjusted
-- map should go
adjustedPath :: Text -> Org True -> Text -- TODO: filepath library using Text?
adjustedPath rev org@Org {..} =
  orgWebdir <> "/" <> adjustedWebPath rev org

adjustedWebPath :: Text -> Org True -> Text
adjustedWebPath rev Org {..} =
  rev <> show orgGeneration

newRealtimeChannel :: IO RealtimeChannel
newRealtimeChannel = atomically newBroadcastTChan