packages feed

globus (empty) → 0.1.2

raw patch · 7 files changed

+696/−0 lines, 7 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, effectful, http-api-data, http-types, req, tagged, text

Files

+ README.md view
@@ -0,0 +1,5 @@+Globus.hs+==========+++Haskell Client for [Globus File Transfer API](https://docs.globus.org/api/)
+ globus.cabal view
@@ -0,0 +1,55 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name:           globus+version:        0.1.2+synopsis:       GLOBUS Data Transfer+category:       System, Data+homepage:       https://github.com/DKISTDC/globus-hs+author:         Sean Hess+maintainer:     shess@nso.edu+license:        BSD-3-Clause+build-type:     Simple+extra-doc-files:+    README.md++library+  exposed-modules:+      Effectful.Globus+      Network.Globus+      Network.Globus.Auth+      Network.Globus.Transfer+      Network.Globus.Types+  other-modules:+      Paths_globus+  autogen-modules:+      Paths_globus+  hs-source-dirs:+      src+  default-extensions:+      TypeFamilies+      DataKinds+      DeriveAnyClass+      DerivingStrategies+      OverloadedRecordDot+      OverloadedStrings+      QuasiQuotes+      DuplicateRecordFields+      LambdaCase+      NoFieldSelectors+      StrictData+  ghc-options: -Wall+  build-depends:+      aeson >=2 && <2.3+    , base >=4.16.4.0 && <5+    , bytestring >=0.11 && <0.13+    , effectful ==2.3.*+    , http-api-data ==0.6.*+    , http-types ==0.12.*+    , req ==3.13.*+    , tagged ==0.8.*+    , text ==2.*+  default-language: GHC2021
+ src/Effectful/Globus.hs view
@@ -0,0 +1,67 @@+module Effectful.Globus+  ( Globus (..)+  , GlobusClient (..)+  , runGlobus+  , State (..)+  , Req.Scheme (..)+  , Tagged (..)+  , module Network.Globus.Types+  , TransferRequest (..)+  , TransferResponse (..)+  , TransferItem (..)+  , SyncLevel (..)+  , Task (..)+  , TaskStatus (..)+  , TaskFilters (..)+  , TaskList (..)+  ) where++import Data.List.NonEmpty (NonEmpty)+import Data.Tagged+import Effectful+import Effectful.Dispatch.Dynamic+import Network.Globus.Auth+import Network.Globus.Transfer+import Network.Globus.Types+import Network.HTTP.Req as Req+++data GlobusClient = GlobusClient+  { clientId :: Token ClientId+  , clientSecret :: Token ClientSecret+  }+++data Globus :: Effect where+  AuthUrl :: Uri Redirect -> NonEmpty Scope -> State -> Globus m (Uri Authorization)+  GetUserInfo :: Token OpenId -> Globus m UserInfoResponse+  GetAccessTokens :: Token Exchange -> Uri Redirect -> Globus m (NonEmpty TokenItem)+  SubmissionId :: Token Access -> Globus m (Id Submission)+  Transfer :: Token Access -> TransferRequest -> Globus m TransferResponse+  StatusTask :: Token Access -> Id Task -> Globus m Task+  StatusTasks :: Token Access -> TaskFilters -> Globus m TaskList+++type instance DispatchOf Globus = 'Dynamic+++runGlobus+  :: (IOE :> es)+  => GlobusClient+  -> Eff (Globus : es) a+  -> Eff es a+runGlobus g = interpret $ \_ -> \case+  GetAccessTokens exc red -> do+    liftIO $ fetchAccessTokens g.clientId g.clientSecret red exc+  GetUserInfo ti -> do+    liftIO $ fetchUserInfo ti+  AuthUrl red scopes state -> do+    pure $ authorizationUrl g.clientId red scopes state+  SubmissionId access -> do+    liftIO $ fetchSubmissionId access+  Transfer access request -> do+    liftIO $ sendTransfer access request+  StatusTask access ti -> do+    liftIO $ fetchTask access ti+  StatusTasks access tf -> do+    liftIO $ fetchTasks access tf
+ src/Network/Globus.hs view
@@ -0,0 +1,14 @@+module Network.Globus+  ( module Network.Globus.Types+  , Tagged (..)+  , module Network.Globus.Auth+  , Req.Scheme (..)+  , module Network.Globus.Transfer+  ) where++import Data.Tagged (Tagged (..))+import Network.Globus.Auth+import Network.Globus.Transfer+import Network.Globus.Types+import Network.HTTP.Req as Req+
+ src/Network/Globus/Auth.hs view
@@ -0,0 +1,154 @@+module Network.Globus.Auth where++import Data.Aeson+import Data.Aeson.Types+import Data.List qualified as L+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.String (IsString)+import Data.Tagged+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding (encodeUtf8)+import Effectful (MonadIO)+import GHC.Generics (Generic)+import Network.Globus.Types+import Network.HTTP.Req as Req+++-- | Opaque secret identifying the user. Validate on redirect+newtype State = State Text+  deriving newtype (IsString, FromJSON)+  deriving (Show)+++-- | The end user must visit this url+authorizationUrl :: Token ClientId -> Uri Redirect -> NonEmpty Scope -> State -> Uri Authorization+authorizationUrl (Tagged cid) red scopes (State st) =+  -- TODO: does the auth url need the security token?+  authorizeEndpoint{params = query}+ where+  query :: Query+  query =+    "client_id" =: cid+      <> "response_type" =: ("code" :: Text)+      <> "scope" =: Text.intercalate " " (scopeText <$> NE.toList scopes)+      <> "state" =: st+      <> redirectUri red++  authorizeEndpoint :: Uri Authorization+  authorizeEndpoint = Uri Https "auth.globus.org" ["v2", "oauth2", "authorize"] (Query [])+++fetchAccessTokens :: (MonadIO m) => Token ClientId -> Token ClientSecret -> Uri Redirect -> Token Exchange -> m (NonEmpty TokenItem)+fetchAccessTokens (Tagged cid) (Tagged sec) red (Tagged code) = do+  runReq defaultHttpConfig $ do+    res <-+      req POST tokenEndpoint NoReqBody jsonResponse $+        "grant_type" =: ("authorization_code" :: Text)+          <> "code" =: code+          <> redirectUri red+          -- TODO: is this the correct basic auth?+          <> basicAuth (encodeUtf8 cid) (encodeUtf8 sec)++    -- liftIO $ print $ responseBody res+    let TokenResponse toks = responseBody res :: TokenResponse+    pure toks+ where+  tokenEndpoint :: Req.Url 'Https+  tokenEndpoint = https "auth.globus.org" /: "v2" /: "oauth2" /: "token"+++redirectUri :: (QueryParam param) => Uri Redirect -> param+redirectUri red = "redirect_uri" =: renderUri red+++-- | fetchAccessTokens returns a non-empty list matching the scopes+newtype TokenResponse = TokenResponse (NonEmpty TokenItem)+  deriving (Show)+++instance FromJSON TokenResponse where+  parseJSON = withObject "TokenResponse" $ \m -> do+    token <- parseJSON $ Object m :: Parser TokenItem+    other <- m .: "other_tokens"+    pure $ TokenResponse $ token :| other+++data TokenItem = TokenItem+  { scope :: Scopes+  , access_token :: Token Access+  , expires_in :: Int+  , -- , resource_server :: Text -- "transfer.api.globus.org"+    -- , tokenType :: Text -- "Bearer"+    state :: State+    -- , refresh_token :: Token Refresh+    -- id_token :: Token Identity+  }+  deriving (Generic, FromJSON, Show)+++scopeToken :: Scope -> NonEmpty TokenItem -> Maybe (Token Access)+scopeToken s ts = do+  item <- L.find (\i -> hasScope i.scope) $ NE.toList ts+  pure item.access_token+ where+  hasScope (Scopes ss) = s `elem` ss+++-- | You MUST include the OpenId Scope for this to work+fetchUserInfo :: (MonadIO m) => Token OpenId -> m UserInfoResponse+fetchUserInfo to =+  runReq defaultHttpConfig $ do+    res <-+      req POST endpoint NoReqBody jsonResponse $+        identityAuth to+    pure $ responseBody res+ where+  endpoint :: Req.Url 'Https+  endpoint = https "auth.globus.org" /: "v2" /: "oauth2" /: "userinfo"+++identityAuth :: Token OpenId -> Option Https+identityAuth (Tagged oid) = oAuth2Bearer (encodeUtf8 oid)+++--  where+--   tokenEndpoint :: Req.Url 'Https+--   tokenEndpoint = https "auth.globus.org" /: "v2" /: "oauth2" /: "token"+--+data UserInfoResponse = UserInfoResponse+  { info :: UserInfo+  , email :: Maybe UserEmail+  , profile :: Maybe UserProfile+  }+++instance FromJSON UserInfoResponse where+  parseJSON = withObject "UserInfo" $ \m -> do+    info <- parseJSON $ Object m+    email <- m .:? "email"+    profile <- parseJSON $ Object m+    pure $ UserInfoResponse{info, email, profile}+++data UserInfo = UserInfo+  { sub :: Text+  , last_authentication :: Int+  -- , identity_set :: Value+  }+  deriving (Generic, FromJSON, Show)+++newtype UserEmail = UserEmail Text+  deriving newtype (FromJSON, Show, Eq)+++data UserProfile = UserProfile+  { name :: Text+  , organization :: Text+  , preferred_username :: Text+  , identity_provider :: Text+  , identity_provider_display_name :: Text+  }+  deriving (Generic, FromJSON, Show)
+ src/Network/Globus/Transfer.hs view
@@ -0,0 +1,249 @@+module Network.Globus.Transfer where++import Data.Aeson+import Data.Char (toUpper)+import Data.Tagged+import Data.Text (Text, pack)+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8)+import Effectful (MonadIO)+import GHC.Generics (Generic, Rep)+import Network.Globus.Types+import Network.HTTP.Req as Req+++-- -----------------------------------------+-- API+-- -----------------------------------------++fetchSubmissionId :: (MonadIO m) => Token Access -> m (Id Submission)+fetchSubmissionId access =+  runReq defaultHttpConfig $ do+    res <- req GET (transferEndpoint /: "submission_id") NoReqBody jsonResponse (transferAuth access)+    let idRes = responseBody res :: IdResponse+    pure $ Tagged idRes.value+++transferAuth :: Token Access -> Option Https+transferAuth (Tagged access) = oAuth2Bearer (encodeUtf8 access)+++transferEndpoint :: Req.Url 'Https+transferEndpoint = https "transfer.api.globus.org" /: "v0.10"+++sendTransfer :: (MonadIO m) => Token Access -> TransferRequest -> m TransferResponse+sendTransfer access request =+  runReq defaultHttpConfig $ do+    res <- req POST (transferEndpoint /: "transfer") (ReqBodyJson request) jsonResponse (transferAuth access)+    let tr = responseBody res :: TransferResponse+    pure tr+++-- https://docs.globus.org/api/transfer/task/#get_task_by_id+fetchTask :: (MonadIO m) => Token Access -> Id Task -> m Task+fetchTask access (Tagged ti) = do+  runReq defaultHttpConfig $ do+    res <- req GET (transferEndpoint /: "task" /: ti) NoReqBody jsonResponse (transferAuth access)+    pure (responseBody res)+++newtype TaskFilters = TaskFilters+  { status :: [TaskStatus]+  }+  deriving (Show, Eq)+instance Monoid TaskFilters where+  mempty = TaskFilters []+instance Semigroup TaskFilters where+  tf1 <> tf2 = TaskFilters{status = tf1.status <> tf2.status}+++fetchTasks :: (MonadIO m) => Token Access -> TaskFilters -> m TaskList+fetchTasks access tf = do+  runReq defaultHttpConfig $ do+    res <-+      req GET (transferEndpoint /: "task_list") NoReqBody jsonResponse $+        transferAuth access+          <> "filter" =: status tf.status+    pure (responseBody res)+ where+  status :: [TaskStatus] -> Text+  status [] = ""+  status ss = "status:" <> T.intercalate "," (map (T.toUpper . pack . show) ss)+++activityUrl :: Id Task -> Uri App+activityUrl (Tagged t) =+  Uri Https "app.globus.org" ["activity", t] (Query [])+++taskPercentComplete :: Task -> Float+taskPercentComplete t+  | t.status == Succeeded = 1+  | otherwise = max bytesProgress filesProgress+ where+  bytesProgress+    | t.bytes_checksummed == 0 = 0+    | otherwise = fromIntegral t.bytes_transferred / fromIntegral t.bytes_checksummed+  filesProgress+    | t.files == 0 = 0+    | otherwise = fromIntegral (t.files_skipped + t.files_transferred) / fromIntegral t.files+++-- -----------------------------------------+-- Submission Ids+-- -----------------------------------------++data IdResponse = IdResponse+  { value :: Text+  }+  deriving (Generic, FromJSON, Show)+++-- -----------------------------------------+-- Tasks+-- -----------------------------------------++-- https://docs.globus.org/api/transfer/task/#task_document+data Task = Task+  { status :: TaskStatus+  , task_id :: Id Task+  , label :: Text+  , -- , request_time :: UTCTime+    -- , completion_time :: Maybe UTCTime+    files :: Int+  , directories :: Int+  , files_skipped :: Int+  , files_transferred :: Int+  , bytes_transferred :: Int+  , bytes_checksummed :: Int+  , effective_bytes_per_second :: Int+  , nice_status :: Maybe Text+  , source_endpoint_id :: Id Collection+  , destination_endpoint_id :: Id Collection+  }+  deriving (Generic, FromJSON, Show, Eq)+++data TaskStatus+  = Active+  | Inactive+  | Succeeded+  | Failed+  deriving (Generic, Show, Eq)+++instance FromJSON TaskStatus where+  parseJSON = genericParseJSON defaultOptions{constructorTagModifier = map toUpper}+++-- -----------------------------------------+-- Tasks+-- -----------------------------------------++data TaskList = TaskList+  { length :: Int+  , limit :: Int+  , offset :: Int+  , total :: Int+  , data_ :: [Task]+  }+  deriving (Generic, Show)+++instance FromJSON TaskList where+  parseJSON = genericParseJSON defaultOptions{fieldLabelModifier = dataLabels}+++-- -----------------------------------------+-- Transfers+-- -----------------------------------------++data TransferResponse = TransferResponse+  { task_id :: Id Task+  , submission_id :: Token Submission+  , -- , code :: TransferCode -- Accepted, Duplicate+    message :: Text+  , resource :: Text+  , request_id :: Token Request+  }+  deriving (Generic, FromJSON, Show)+++-- https://docs.globus.org/api/transfer/task_submit/#transfer_and_delete_documents+data TransferRequest = TransferRequest+  { data_type :: DataType "transfer"+  , submission_id :: Id Submission+  , label :: Maybe Text+  , -- , notify_on_succeeded :: Bool -- Default true+    -- , notify_on_failed :: Bool -- Default true+    -- deadline+    source_endpoint :: Id Collection+  , destination_endpoint :: Id Collection+  , data_ :: [TransferItem]+  , -- , filter_rules :: [FilterRule]+    sync_level :: SyncLevel+  , -- , encrypt_data+    store_base_path_info :: Bool+  }+  deriving (Generic)+++instance ToJSON TransferRequest where+  toJSON = dataLabelsJson+++-- https://docs.globus.org/api/transfer/task_submit/#transfer_item_fields+data TransferItem = TransferItem+  { data_type :: DataType "transfer_item"+  , source_path :: FilePath+  , destination_path :: FilePath+  , recursive :: Bool+  -- , external_checksum :: Text+  -- , checksum_algorithm :: Text+  -- , verify_checksum = false+  -- preserve_timestamp = false+  -- delete_destination_extra = false+  -- recursive_symlinks+  -- skip_source-errors ?? default?+  -- fail_on_quota_errors ??+  }+  deriving (Generic)+++instance ToJSON TransferItem where+  toJSON = dataLabelsJson+++-- newtype FilterRule = FilterRule+--   { data_type :: DataType "filter_rule"+--   -- , method :: FilterMethod+--   -- , type_ :: FilterType+--   -- , name :: Text+--   }+--   deriving (Generic, ToJSON)++data SyncLevel+  = SyncExists+  | SyncSize+  | SyncTimestamp+  | SyncChecksum+++instance ToJSON SyncLevel where+  toJSON = Number . toInt+   where+    toInt SyncExists = 0+    toInt SyncSize = 1+    toInt SyncTimestamp = 2+    toInt SyncChecksum = 3+++dataLabelsJson :: (Generic a, GToJSON' Value Zero (Rep a)) => a -> Value+dataLabelsJson = genericToJSON defaultOptions{fieldLabelModifier = dataLabels}+++dataLabels :: String -> String+dataLabels "data_" = "DATA"+dataLabels "data_type" = "DATA_TYPE"+dataLabels f = f
+ src/Network/Globus/Types.hs view
@@ -0,0 +1,152 @@+module Network.Globus.Types where++import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText)+import Data.Char (toLower)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Proxy (Proxy (..))+import Data.Tagged+import Data.Text (Text, pack, splitOn, unpack)+import Data.Text qualified as Text+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import GHC.IsList (IsList (..))+import GHC.TypeLits+import Network.HTTP.Req as Req+import Network.HTTP.Types (urlEncode)+import Web.HttpApiData (toQueryParam)+++type Token a = Tagged a Text+type Id a = Tagged a Text+++data Token'+  = ClientId+  | ClientSecret+  | Exchange+  | Access+++data Id'+  = Submission+  | Request+  | Collection+++data DataType (s :: Symbol) = DataType+++instance (KnownSymbol s) => ToJSON (DataType s) where+  toJSON _ = String $ pack $ symbolVal @s Proxy+++data Endpoint+  = Redirect+  | Authorization+  | Tokens+  | App+++-- | Simple URI Type, since all the others are obnoxious+data Uri (a :: Endpoint) = Uri+  { scheme :: Scheme+  , domain :: Text+  , path :: [Text]+  , params :: Query+  }+++renderUri :: Uri a -> Text+renderUri u =+  scheme <> endpoint <> path <> query+ where+  scheme =+    case u.scheme of+      Http -> "http://"+      Https -> "https://"+  endpoint = cleanSlash u.domain+  path = "/" <> Text.intercalate "/" (map cleanSlash u.path)+  query =+    case renderQuery u.params of+      "" -> ""+      q -> "?" <> q+  cleanSlash = Text.dropWhileEnd (== '/') . Text.dropWhile (== '/')+++instance Show (Uri a) where+  show = Text.unpack . renderUri+++newtype Query = Query [(Text, Maybe Text)]+  deriving newtype (Monoid, Semigroup)+++instance Show Query where+  show = Text.unpack . renderQuery+++instance IsList Query where+  type Item Query = (Text, Maybe Text)+  fromList = Query+  toList (Query ps) = ps+++instance Req.QueryParam Query where+  queryParam t ma = Query [(t, toQueryParam <$> ma)]+  queryParamToList (Query ps) = ps+++renderQuery :: Query -> Text+renderQuery (Query ps) = Text.intercalate "&" $ map toText ps+ where+  toText (p, Nothing) = p+  toText (p, Just v) = p <> "=" <> value v++  value = decodeUtf8 . urlEncode True . encodeUtf8+++data Scope+  = -- TODO: figure out all scopes and hard-code+    TransferAll+  | Identity ScopeIdentity+  deriving (Show, Eq)+++data ScopeIdentity+  = OpenId+  | Email+  | Profile+  deriving (Show, Eq)+++scopeText :: Scope -> Text+scopeText TransferAll = "urn:globus:auth:scope:transfer.api.globus.org:all"+scopeText (Identity i) = pack $ toLower <$> show i+++scope :: Text -> Maybe Scope+scope "urn:globus:auth:scope:transfer.api.globus.org:all" = Just TransferAll+scope "email" = Just $ Identity Email+scope "profile" = Just $ Identity Profile+scope "openid" = Just $ Identity OpenId+scope _ = Nothing+++instance FromJSON Scope where+  parseJSON = withText "Scope" $ \t -> do+    maybe (fail $ "Invalid scope:" <> unpack t) pure $ scope t+++newtype Scopes = Scopes (NonEmpty Scope)+  deriving newtype (Show)+++instance FromJSON Scopes where+  parseJSON = withText "Scopes" $ \t -> do+    ts <- parseSplitSpace t+    ss <- mapM (parseJSON . String) ts+    pure $ Scopes ss+   where+    parseSplitSpace t = do+      case splitOn " " t of+        (s : ss) -> pure $ s :| ss+        _ -> fail $ "Scopes split on spaces " <> unpack t