{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}

module TahoeLAFS.Storage.Client (
    -- General server info
    version,
    -- Mutable or immutable
    renewLease,
    -- Immutable operations
    createImmutableStorageIndex,
    writeImmutableShare,
    abortImmutableUpload,
    readImmutableShare,
    getImmutableShareNumbers,
    adviseCorruptImmutableShare,
    -- Mutable operations
    readTestWrite,
    readMutableShares,
    getMutableShareNumbers,
    adviseCorruptMutableShare,
    parseNURL,
    runGBS,
    NURL (..),
) where

import Control.Monad ((>=>))
import qualified "base64" Data.ByteString.Base64.URL as Base64URL
import Data.Proxy (Proxy (..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Client.TLS (
    newTlsManagerWith,
 )
import Network.Socket (HostName, PortNumber)
import Network.URI (
    -- URI (URI, uriAuthority, uriPath),
    URIAuth (URIAuth, uriPort, uriRegName, uriUserInfo),
    parseURI,
 )
import Servant (
    URI (URI, uriAuthority, uriFragment, uriPath),
    type (:<|>) ((:<|>)),
 )
import Servant.Client (
    BaseUrl (BaseUrl),
    ClientError,
    ClientM,
    Scheme (Https),
    client,
    mkClientEnv,
    runClientM,
 )
import TahoeLAFS.Internal.Client (SPKIHash (SPKIHash), mkGBSManagerSettings)
import TahoeLAFS.Storage.API (
    StorageAPI,
 )
import Text.Read (readMaybe)

newApi :: Proxy StorageAPI
newApi :: Proxy StorageAPI
newApi = Proxy StorageAPI
forall k (t :: k). Proxy t
Proxy
( ClientM Version
version
        :<|> [Char] -> Maybe [LeaseSecret] -> ClientM ()
renewLease
        :<|> [Char]
-> Maybe [LeaseSecret]
-> AllocateBuckets
-> ClientM AllocationResult
createImmutableStorageIndex
        :<|> [Char]
-> ShareNumber
-> Maybe [LeaseSecret]
-> ByteString
-> Maybe [ByteRange]
-> ClientM ()
writeImmutableShare
        :<|> [Char] -> ShareNumber -> Maybe [LeaseSecret] -> ClientM ()
abortImmutableUpload
        :<|> [Char] -> ShareNumber -> Maybe [ByteRange] -> ClientM ByteString
readImmutableShare
        :<|> [Char] -> ClientM (CBORSet ShareNumber)
getImmutableShareNumbers
        :<|> [Char] -> ShareNumber -> CorruptionDetails -> ClientM ()
adviseCorruptImmutableShare
        :<|> [Char]
-> Maybe [LeaseSecret]
-> ReadTestWriteVectors
-> ClientM ReadTestWriteResult
readTestWrite
        :<|> [Char] -> ShareNumber -> Maybe [ByteRange] -> ClientM ByteString
readMutableShares
        :<|> [Char] -> ClientM (CBORSet ShareNumber)
getMutableShareNumbers
        :<|> [Char] -> ShareNumber -> CorruptionDetails -> ClientM ()
adviseCorruptMutableShare
    ) = Proxy StorageAPI -> Client ClientM StorageAPI
forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client Proxy StorageAPI
newApi

-- | Represent a "new" style service URL.
data NURL = NURLv1
    { -- | The cryptographic fingerprint of the server hosting the service.
      NURL -> SPKIHash
nurlv1Fingerprint :: SPKIHash
    , -- | A hint about the network location of the server hosting the service.
      NURL -> ([Char], PortNumber)
nurlv1Address :: (HostName, PortNumber)
    , -- | The secret identifier for the service within the scope of the server.
      NURL -> Text
nurlv1Swissnum :: T.Text
    }
    deriving (Eq NURL
Eq NURL
-> (NURL -> NURL -> Ordering)
-> (NURL -> NURL -> Bool)
-> (NURL -> NURL -> Bool)
-> (NURL -> NURL -> Bool)
-> (NURL -> NURL -> Bool)
-> (NURL -> NURL -> NURL)
-> (NURL -> NURL -> NURL)
-> Ord NURL
NURL -> NURL -> Bool
NURL -> NURL -> Ordering
NURL -> NURL -> NURL
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NURL -> NURL -> NURL
$cmin :: NURL -> NURL -> NURL
max :: NURL -> NURL -> NURL
$cmax :: NURL -> NURL -> NURL
>= :: NURL -> NURL -> Bool
$c>= :: NURL -> NURL -> Bool
> :: NURL -> NURL -> Bool
$c> :: NURL -> NURL -> Bool
<= :: NURL -> NURL -> Bool
$c<= :: NURL -> NURL -> Bool
< :: NURL -> NURL -> Bool
$c< :: NURL -> NURL -> Bool
compare :: NURL -> NURL -> Ordering
$ccompare :: NURL -> NURL -> Ordering
$cp1Ord :: Eq NURL
Ord, NURL -> NURL -> Bool
(NURL -> NURL -> Bool) -> (NURL -> NURL -> Bool) -> Eq NURL
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NURL -> NURL -> Bool
$c/= :: NURL -> NURL -> Bool
== :: NURL -> NURL -> Bool
$c== :: NURL -> NURL -> Bool
Eq, Int -> NURL -> ShowS
[NURL] -> ShowS
NURL -> [Char]
(Int -> NURL -> ShowS)
-> (NURL -> [Char]) -> ([NURL] -> ShowS) -> Show NURL
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NURL] -> ShowS
$cshowList :: [NURL] -> ShowS
show :: NURL -> [Char]
$cshow :: NURL -> [Char]
showsPrec :: Int -> NURL -> ShowS
$cshowsPrec :: Int -> NURL -> ShowS
Show)

-- | Parse a Great Black Swamp NURL from text.
parseNURL :: T.Text -> Maybe NURL
parseNURL :: Text -> Maybe NURL
parseNURL = [Char] -> Maybe URI
parseURI ([Char] -> Maybe URI) -> (Text -> [Char]) -> Text -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> Maybe URI) -> (URI -> Maybe NURL) -> Text -> Maybe NURL
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> URI -> Maybe NURL
uriToNURL

uriToNURL :: URI -> Maybe NURL
uriToNURL :: URI -> Maybe NURL
uriToNURL URI{uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Just URIAuth{[Char]
uriUserInfo :: [Char]
uriUserInfo :: URIAuth -> [Char]
uriUserInfo, uriRegName :: URIAuth -> [Char]
uriRegName = [Char]
hostname, uriPort :: URIAuth -> [Char]
uriPort = (Char
':' : [Char]
port)}, uriPath :: URI -> [Char]
uriPath = (Char
'/' : [Char]
swissnum), uriFragment :: URI -> [Char]
uriFragment = [Char]
"#v=1"} =
    case (Either Text SPKIHash
requiredHashE, Maybe PortNumber
portM) of
        (Left Text
_, Maybe PortNumber
_) -> Maybe NURL
forall a. Maybe a
Nothing
        (Either Text SPKIHash
_, Maybe PortNumber
Nothing) -> Maybe NURL
forall a. Maybe a
Nothing
        (Right SPKIHash
requiredHash, Just PortNumber
portNum) -> NURL -> Maybe NURL
forall a. a -> Maybe a
Just NURLv1 :: SPKIHash -> ([Char], PortNumber) -> Text -> NURL
NURLv1{nurlv1Fingerprint :: SPKIHash
nurlv1Fingerprint = SPKIHash
requiredHash, nurlv1Address :: ([Char], PortNumber)
nurlv1Address = ([Char]
hostname, PortNumber
portNum), nurlv1Swissnum :: Text
nurlv1Swissnum = [Char] -> Text
T.pack [Char]
swissnum}
  where
    requiredHashE :: Either Text SPKIHash
requiredHashE = (ByteString -> SPKIHash)
-> Either Text ByteString -> Either Text SPKIHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> SPKIHash
SPKIHash (Either Text ByteString -> Either Text SPKIHash)
-> ([Char] -> Either Text ByteString)
-> [Char]
-> Either Text SPKIHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text ByteString
Base64URL.decodeBase64 (ByteString -> Either Text ByteString)
-> ([Char] -> ByteString) -> [Char] -> Either Text ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> ([Char] -> Text) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text) -> ShowS -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
dropLast Int
1 ([Char] -> Either Text SPKIHash) -> [Char] -> Either Text SPKIHash
forall a b. (a -> b) -> a -> b
$ [Char]
uriUserInfo
    portM :: Maybe PortNumber
portM = [Char] -> Maybe PortNumber
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
port
uriToNURL URI
_ = Maybe NURL
forall a. Maybe a
Nothing

{- | Execute some client operations against the Great Black Swamp server at
 the location indicated by the given NURL.
-}
runGBS :: NURL -> ClientM a -> IO (Either ClientError a)
runGBS :: NURL -> ClientM a -> IO (Either ClientError a)
runGBS NURLv1{SPKIHash
nurlv1Fingerprint :: SPKIHash
nurlv1Fingerprint :: NURL -> SPKIHash
nurlv1Fingerprint, nurlv1Address :: NURL -> ([Char], PortNumber)
nurlv1Address = ([Char]
hostname, PortNumber
port), Text
nurlv1Swissnum :: Text
nurlv1Swissnum :: NURL -> Text
nurlv1Swissnum} ClientM a
action = do
    Manager
manager <- ManagerSettings -> IO Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
newTlsManagerWith (SPKIHash -> Text -> ManagerSettings
mkGBSManagerSettings SPKIHash
nurlv1Fingerprint Text
nurlv1Swissnum)
    let clientEnv :: ClientEnv
clientEnv = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager (Scheme -> [Char] -> Int -> [Char] -> BaseUrl
BaseUrl Scheme
Https [Char]
hostname (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port) [Char]
"")
    ClientM a -> ClientEnv -> IO (Either ClientError a)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM a
action ClientEnv
clientEnv

dropLast :: Int -> [a] -> [a]
dropLast :: Int -> [a] -> [a]
dropLast Int
n [a]
xs =
    Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) [a]
xs