{-# 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.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
$ Text -> ProjectBranchName
UnsafeProjectBranchName Text
"main")
          (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
$sel:project:Current :: Current -> Maybe ProjectName
$sel:branch:Current :: Current -> Maybe ProjectBranchName
$sel:path:Current :: Current -> Absolute
project :: Maybe ProjectName
branch :: Maybe ProjectBranchName
path :: Absolute
..}) =
    [Pair] -> Value
object
      [ Key
"project" Key -> Maybe ProjectName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Maybe ProjectName
project,
        Key
"branch" Key -> Maybe ProjectBranchName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Maybe ProjectBranchName
branch,
        Key
"path" Key -> Absolute -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= 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
  ProjectPath
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 ProjectName
projName ProjectBranchName
branchName Absolute
path) = ProjectPath -> ProjectPathG ProjectName ProjectBranchName
PP.toNames ProjectPath
pp
  Current -> m Current
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Current -> m Current) -> Current -> m Current
forall a b. (a -> b) -> a -> b
$ Maybe ProjectName -> Maybe ProjectBranchName -> Absolute -> Current
Current (ProjectName -> Maybe ProjectName
forall a. a -> Maybe a
Just ProjectName
projName) (ProjectBranchName -> Maybe ProjectBranchName
forall a. a -> Maybe a
Just ProjectBranchName
branchName) Absolute
path