{-# Language TemplateHaskell #-}
{-# Language UndecidableInstances #-}
{-# Language AllowAmbiguousTypes #-}
module HBS2.CLI.Run.Internal
  ( module HBS2.CLI.Run.Internal
  , module SC
  ) where

import HBS2.CLI.Prelude

import HBS2.System.Dir

import HBS2.OrDie
import HBS2.Base58
import HBS2.Data.Types.Refs
import HBS2.Storage
import HBS2.Peer.CLI.Detect
import HBS2.Peer.RPC.Client
import HBS2.Peer.RPC.Client.Unix
import HBS2.Peer.RPC.API.Peer
import HBS2.Peer.RPC.API.RefLog
import HBS2.Peer.RPC.API.RefChan
import HBS2.Peer.RPC.API.LWWRef
import HBS2.Peer.RPC.API.Storage
import HBS2.Peer.RPC.API.RefChan
import HBS2.Peer.RPC.Client.StorageClient

import Data.Config.Suckless.Script qualified as SC
import Data.Config.Suckless.Script hiding (internalEntries)

import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Cont
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as LBS
import Data.Text qualified as Text
import Lens.Micro.Platform


data HBS2CliEnv =
  HBS2CliEnv
  { _peerSocket      :: FilePath
  , _peerRefChanAPI  :: ServiceCaller RefChanAPI UNIX
  , _peerRefLogAPI   :: ServiceCaller RefLogAPI UNIX
  , _peerLwwRefAPI   :: ServiceCaller LWWRefAPI UNIX
  , _peerPeerAPI     :: ServiceCaller PeerAPI UNIX
  , _peerStorageAPI  :: ServiceCaller StorageAPI UNIX
  }

makeLenses 'HBS2CliEnv

newtype HBS2Cli m a = HBS2Cli { fromHBS2Cli :: ReaderT (TVar (Maybe HBS2CliEnv)) m a }
                      deriving newtype ( Applicative
                                       , Functor
                                       , Monad
                                       , MonadIO
                                       , MonadUnliftIO
                                       , MonadReader (TVar (Maybe HBS2CliEnv))
                                       )

withHBS2Cli :: TVar (Maybe HBS2CliEnv) -> HBS2Cli m a -> m a
withHBS2Cli env action = runReaderT (fromHBS2Cli action) env

recover :: HBS2Cli IO a -> HBS2Cli IO a
recover what = do
  catch what $ \case
    PeerNotConnectedException -> do

      soname <- detectRPC
                  `orDie` "can't locate hbs2-peer rpc"

      flip runContT pure do

        client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
                    >>= orThrowUser ("can't connect to" <+> pretty soname)

        void $ ContT $ withAsync $ runMessagingUnix client

        peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
        refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
        refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname)
        storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
        lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)

        -- let sto = AnyStorage (StorageClient storageAPI)

        let endpoints = [ Endpoint @UNIX  peerAPI
                        , Endpoint @UNIX  refLogAPI
                        , Endpoint @UNIX  refChanAPI
                        , Endpoint @UNIX  lwwAPI
                        , Endpoint @UNIX  storageAPI
                        ]

        void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client

        let env = Just (HBS2CliEnv soname refChanAPI refLogAPI lwwAPI peerAPI storageAPI)
        tv <- newTVarIO env

        liftIO $ withHBS2Cli tv what


runHBS2Cli :: MonadUnliftIO m => HBS2Cli m a -> m a
runHBS2Cli action = do
   noenv <- newTVarIO Nothing
   withHBS2Cli  noenv action

data PeerException =
  PeerNotConnectedException
  deriving stock (Show, Typeable)

instance Exception PeerException


instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where
  getClientAPI = lift (getClientAPI @api @proto)

instance (MonadUnliftIO m, HasStorage m) => HasStorage  (RunM c m) where
  getStorage = lift getStorage

instance (MonadUnliftIO m, HasClientAPI StorageAPI UNIX m, HasStorage m) => HasStorage (ContT a (RunM c m)) where
  getStorage = lift getStorage

instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where
  getClientAPI = lift $ getClientAPI @api @proto

instance MonadUnliftIO m => HasClientAPI RefChanAPI UNIX (HBS2Cli m) where
  getClientAPI = do
    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
    pure $ view peerRefChanAPI what

instance MonadUnliftIO m => HasClientAPI RefLogAPI UNIX (HBS2Cli m) where
  getClientAPI = do
    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
    pure $ view peerRefLogAPI what

instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (HBS2Cli m) where
  getClientAPI = do
    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
    pure $ view peerPeerAPI what

instance MonadUnliftIO m => HasClientAPI StorageAPI UNIX (HBS2Cli m) where
  getClientAPI = do
    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
    pure $ view peerStorageAPI what

instance MonadUnliftIO m => HasClientAPI LWWRefAPI UNIX (HBS2Cli m) where
  getClientAPI = do
    what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException
    pure $ view peerLwwRefAPI what

instance MonadUnliftIO m => HasStorage (HBS2Cli m) where
  getStorage = getClientAPI @StorageAPI @UNIX  <&> AnyStorage . StorageClient

internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
internalEntries = do
    SC.internalEntries

    entry $ bindMatch "--run" $ \case
      [] -> do
        liftIO getContents
           <&> parseTop
           >>= either (error.show) (pure . fmap (fixContext @_ @c))
           >>= evalTop

      [StringLike fn] -> do
        liftIO (readFile fn)
           <&> parseTop
           >>= either (error.show) (pure . fmap (fixContext @_ @c))
           >>= evalTop

      _ -> throwIO (BadFormException @c nil)

    -- TODO: re-implement-all-on-top-of-opaque

    entry $ bindMatch "hbs2:hash" $ \syn -> do
      i <- case syn of
             [ListVal (StringLikeList xs)] -> pure xs
             StringLikeList xs -> pure xs
             e -> throwIO (BadFormException @c (mkList e))

      r <- forM i $ \f -> do
        liftIO (LBS.readFile f)
          <&> hashObject @HbSync
          <&> mkSym @c . show . pretty

      pure $ mkList r

    -- TODO: move-somewhere
    entry $ bindMatch "rm" $ nil_ \case
      [ StringLike p ] -> rm p
      _ -> throwIO (BadFormException @c nil)

    entry $ bindMatch "touch" $ nil_ \case
      [ StringLike p ] -> touch p
      _ -> throwIO (BadFormException @c nil)

    entry $ bindMatch "mkdir" $ nil_ \case
      [ StringLike p ] -> mkdir p
      _ -> throwIO (BadFormException @c nil)

    entry $ bindMatch "blob:base58" $ \case
      [LitStrVal t] -> do
        bs <- pure (Text.unpack t & BS8.pack & fromBase58)
               `orDie` "invalid base58"
              <&> BS8.unpack

        pure (mkForm "blob" [mkStr @c bs])

      _ -> throwIO (BadFormException @c nil)


    let decodeB58 t = do
          pure (Text.unpack t & BS8.pack & fromBase58)
            `orDie` "invalid base58"

    let decodeAndOut t = do
          liftIO $ BS8.putStr =<< decodeB58 t

    entry $ bindMatch "base58:encode" $ \case
      [LitStrVal t] -> do
        let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack
        pure (mkForm "blob:base58" [mkStr @c s])

      [ListVal [SymbolVal "blob", LitStrVal t]] -> do
        let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack
        pure (mkForm "blob:base58" [mkStr @c s])

      e -> throwIO (BadFormException @c nil)

    entry $ bindMatch "base58:decode" $ \case

      [ListVal [SymbolVal "blob:base58", LitStrVal t]] -> do
        s <- decodeB58 t <&> BS8.unpack
        pure $ mkForm "blob" [mkStr @c s]

      e -> throwIO (BadFormException @c nil)

    entry $ bindMatch "base58:put" $ nil_ $ \case
      [ListVal [SymbolVal "blob:base58", LitStrVal t]] ->
        decodeAndOut t

      [LitStrVal t] -> decodeAndOut t

      e -> throwIO (BadFormException @c nil)

    entry $ bindMatch "test:opaque" $ \case
      [ LitIntVal n ] -> mkOpaque n
      [ StringLike s ] -> mkOpaque s

      _ -> mkOpaque ()