{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.IPFS.Git.RemoteHelper.Options where
import Control.Applicative (liftA2, (<|>))
import Control.Exception.Safe (throwString)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Function (on)
import Data.Git (withCurrentRepo)
import qualified Data.Git.Repository as Git
import Data.IPLD.CID (CID, cidFromText)
import Data.List (dropWhileEnd)
import Data.Monoid (Last(..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Generics.SOP as SOP
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Network.URI
( parseURI
, uriAuthority
, uriPath
, uriRegName
, uriScheme
)
import Options.Applicative
( Parser
, ReadM
, argument
, eitherReader
, metavar
, strArgument
)
import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)
import System.Environment (lookupEnv)
import Text.Read (readMaybe)
import Network.IPFS.Git.RemoteHelper.Generic
( HKD
, ginvalidate
, gvalidate
)
import Network.IPFS.Git.RemoteHelper.Internal (note)
data Options = Options
{ optRemoteName :: String
, optRemoteUrl :: RemoteUrl
}
data RemoteUrl = RemoteUrl
{ remoteUrlScheme :: Text
, remoteUrlIpfsPath :: IpfsPath
}
data IpfsPath
= IpfsPathIpfs CID
| IpfsPathIpns Text
type IpfsOptions = IpfsOptions' SOP.I
data IpfsOptions' f = IpfsOptions
{ ipfsApiUrl :: HKD f BaseUrl
, ipfsMaxConns :: HKD f Int
, ipfsMaxBlockSize :: HKD f Int
} deriving Generic
instance SOP.Generic (IpfsOptions' f)
instance Semigroup (IpfsOptions' Last) where
a <> b = IpfsOptions
{ ipfsApiUrl = on (<>) ipfsApiUrl a b
, ipfsMaxConns = on (<>) ipfsMaxConns a b
, ipfsMaxBlockSize = on (<>) ipfsMaxBlockSize a b
}
instance Monoid (IpfsOptions' Last) where
mempty = IpfsOptions mempty mempty mempty
mappend = (<>)
defaultIpfsOptions :: IpfsOptions
defaultIpfsOptions = IpfsOptions
{ ipfsApiUrl = BaseUrl Http "localhost" 5001 mempty
, ipfsMaxConns = 30
, ipfsMaxBlockSize = 2048000
}
parseOptions :: Parser Options
parseOptions = liftA2 Options
(strArgument (metavar "REMOTE_NAME"))
(argument remoteUrl (metavar "URL"))
remoteUrl :: ReadM RemoteUrl
remoteUrl = eitherReader $ \s -> do
uri <- note "Invalid URI" $ parseURI s
let path = dropWhile (== '/') $ uriPath uri
ipfs <-
case uriRegName <$> uriAuthority uri of
Just "ipns" -> pure . IpfsPathIpns . Text.pack $ path
_ -> IpfsPathIpfs <$> cidFromString path
pure RemoteUrl
{ remoteUrlScheme = Text.pack . dropWhileEnd (== ':') $ uriScheme uri
, remoteUrlIpfsPath = ipfs
}
where
cidFromString = cidFromText . \case
[] -> emptyRepo
xs -> Text.pack xs
emptyRepo = "QmUNLLsPACCz1vLxQVkXqqLX5R1X345qqfHbsf67hvA3Nn"
getIpfsOptions :: HasCallStack => Options -> IO IpfsOptions
getIpfsOptions Options { optRemoteName } = withCurrentRepo $ \r -> do
ipfsApiUrl <-
fmap Last . runMaybeT $ do
url <-
MaybeT (lookupEnv "IPFS_API_URL")
<|> MaybeT (Git.configGet r ("remote \"" <> optRemoteName <> "\"") "ipfsapiurl")
<|> MaybeT (Git.configGet r "ipfs" "apiurl")
parseBaseUrl url
ipfsMaxConns <-
Last . (>>= readMaybe) <$> Git.configGet r "ipfs" "maxconnections"
ipfsMaxBlockSize <-
Last . (>>= readMaybe) <$> Git.configGet r "ipfs" "maxblocksize"
maybe (throwString "Das Unmögliche ist eingetreten: Invalid IpfsOptions")
pure
. getLast
. gvalidate
$ ginvalidate pure defaultIpfsOptions <> IpfsOptions {..}