{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}

module Unison.Server.Local.Endpoints.Current where

import Data.Aeson
import Data.OpenApi (ToSchema (..))
import Servant ((:>))
import Servant.Docs (ToSample (..))
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
import Unison.Prelude
import Unison.Project (defaultBranchName)
import Unison.Server.Backend
import Unison.Server.Types (APIGet)

type CurrentEndpoint =
  "current"
    :> APIGet Current

data Current = Current
  { Current -> Maybe ProjectName
project :: Maybe ProjectName,
    Current -> Maybe ProjectBranchName
branch :: Maybe ProjectBranchName,
    Current -> Absolute
path :: Path.Absolute
  }
  deriving stock ((forall x. Current -> Rep Current x)
-> (forall x. Rep Current x -> Current) -> Generic Current
forall x. Rep Current x -> Current
forall x. Current -> Rep Current x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Current -> Rep Current x
from :: forall x. Current -> Rep Current x
$cto :: forall x. Rep Current x -> Current
to :: forall x. Rep Current x -> Current
Generic, Int -> Current -> ShowS
[Current] -> ShowS
Current -> String
(Int -> Current -> ShowS)
-> (Current -> String) -> ([Current] -> ShowS) -> Show Current
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Current -> ShowS
showsPrec :: Int -> Current -> ShowS
$cshow :: Current -> String
show :: Current -> String
$cshowList :: [Current] -> ShowS
showList :: [Current] -> ShowS
Show)
  deriving anyclass (Typeable Current
Typeable Current =>
(Proxy Current -> Declare (Definitions Schema) NamedSchema)
-> ToSchema Current
Proxy Current -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy Current -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy Current -> Declare (Definitions Schema) NamedSchema
ToSchema)

instance ToSample Current where
  toSamples :: Proxy Current -> [(Text, Current)]
toSamples Proxy Current
_ =
    [ ( Text
"Current ucm state",
        Maybe ProjectName -> Maybe ProjectBranchName -> Absolute -> Current
Current
          (ProjectName -> Maybe ProjectName
forall a. a -> Maybe a
Just (ProjectName -> Maybe ProjectName)
-> ProjectName -> Maybe ProjectName
forall a b. (a -> b) -> a -> b
$ Text -> ProjectName
UnsafeProjectName Text
"@unison/base")
          (ProjectBranchName -> Maybe ProjectBranchName
forall a. a -> Maybe a
Just (ProjectBranchName -> Maybe ProjectBranchName)
-> ProjectBranchName -> Maybe ProjectBranchName
forall a b. (a -> b) -> a -> b
$ ProjectBranchName
defaultBranchName)
          (Path -> Absolute
Path.Absolute (Path -> Absolute) -> Path -> Absolute
forall a b. (a -> b) -> a -> b
$ Text -> Path
Path.unsafeParseText Text
"my.path")
      )
    ]

instance ToJSON Current where
  toJSON :: Current -> Value
toJSON (Current {Maybe ProjectBranchName
Maybe ProjectName
Absolute
project :: Current -> Maybe ProjectName
branch :: Current -> Maybe ProjectBranchName
path :: Current -> Absolute
project :: Maybe ProjectName
branch :: Maybe ProjectBranchName
path :: Absolute
..}) =
    [Pair] -> Value
object
      [ Key
"project" Key -> Maybe ProjectName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe ProjectName
project,
        Key
"branch" Key -> Maybe ProjectBranchName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe ProjectBranchName
branch,
        Key
"path" Key -> Absolute -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Absolute
path
      ]

serveCurrent :: (MonadIO m) => Codebase m v a -> Backend m Current
serveCurrent :: forall (m :: * -> *) v a.
MonadIO m =>
Codebase m v a -> Backend m Current
serveCurrent = m Current -> Backend m Current
forall (m :: * -> *) a. Monad m => m a -> Backend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Current -> Backend m Current)
-> (Codebase m v a -> m Current)
-> Codebase m v a
-> Backend m Current
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codebase m v a -> m Current
forall (m :: * -> *) v a. MonadIO m => Codebase m v a -> m Current
getCurrentProjectBranch

getCurrentProjectBranch :: (MonadIO m) => Codebase m v a -> m Current
getCurrentProjectBranch :: forall (m :: * -> *) v a. MonadIO m => Codebase m v a -> m Current
getCurrentProjectBranch Codebase m v a
codebase = do
  pp <- Codebase m v a -> Transaction ProjectPath -> m ProjectPath
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase m v a
codebase Transaction ProjectPath
HasCallStack => Transaction ProjectPath
Codebase.expectCurrentProjectPath
  let (PP.ProjectPath projName branchName path) = PP.toNames pp
  pure $ Current (Just projName) (Just branchName) path