diff --git a/spago.yaml b/spago.yaml index 722593b..5eb29a4 100644 --- a/spago.yaml +++ b/spago.yaml @@ -22,7 +22,7 @@ workspace: extra_packages: fetch: git: 'https://git.orionkindel.com/thunderstrike/purescript-fetch.git' - ref: '01f505d' + ref: 'd74d343' dependencies: - aff - aff-promise diff --git a/src/Gitea.Config.purs b/src/Gitea.Config.purs index ad35e9e..1da9abc 100644 --- a/src/Gitea.Config.purs +++ b/src/Gitea.Config.purs @@ -1,6 +1,9 @@ module Gitea.Config where +import Prelude + import Data.URL (URL) +import Effect (Effect) import Gitea.Auth (Authenticated) -type Config = { baseURI :: URL, auth :: Authenticated } +type Config = { logTrace :: String -> Effect Unit, log :: String -> Effect Unit, baseURI :: URL, auth :: Authenticated } diff --git a/src/Gitea.Error.purs b/src/Gitea.Error.purs index 3537387..205abc2 100644 --- a/src/Gitea.Error.purs +++ b/src/Gitea.Error.purs @@ -17,8 +17,11 @@ data Error | EValidation { message :: String, url :: String } derive instance Generic Error _ -instance Eq Error where eq = genericEq -instance Show Error where show = genericShow +instance Eq Error where + eq = genericEq + +instance Show Error where + show = genericShow guardStatusOk :: forall m. MonadThrow Error m => MonadAff m => HTTP.Response -> m Unit guardStatusOk rep = do diff --git a/src/Gitea.HTTP.purs b/src/Gitea.HTTP.purs new file mode 100644 index 0000000..21207f1 --- /dev/null +++ b/src/Gitea.HTTP.purs @@ -0,0 +1,45 @@ +module Gitea.HTTP where + +import Prelude + +import Control.Monad.Error.Class (catchError) +import Control.Monad.Reader (ask) +import Data.ArrayBuffer.ArrayBuffer as ArrayBuffer +import Data.Foldable (intercalate) +import Data.Maybe (maybe) +import Data.Tuple.Nested ((/\)) +import Data.URL as URL +import Effect.Aff.Class (class MonadAff) +import Effect.Class (liftEffect) +import Gitea.Auth as Auth +import Gitea.Trans (GiteaT(..)) +import HTTP (class Request) +import HTTP as HTTP +import HTTP.Header (Headers(..)) +import HTTP.Request (bodyToRaw, rawRequestBodySize, requestBody, requestHeaders, requestMethod, requestUrl) +import HTTP.Response (Response) +import HTTP.Response as Rep + +fetch :: forall m a. MonadAff m => Request a => a -> GiteaT m Response +fetch req = do + { logTrace, auth } <- ask + method <- requestMethod req + url <- requestUrl req + reqHeaders <- requestHeaders req + authHeaders <- liftEffect $ Auth.headers auth + let headers = reqHeaders <> authHeaders + + body <- requestBody req + rawBody <- bodyToRaw body + bodySize <- liftEffect $ maybe (pure 0) rawRequestBodySize rawBody + + liftEffect $ logTrace $ intercalate " " $ [ show method, show bodySize <> "b", URL.toString url ] + + rep <- HTTP.fetch $ method /\ url /\ body /\ headers + + status <- Rep.status rep + statusText <- Rep.statusText rep + repBodyDebug <- catchError (Rep.text =<< Rep.clone rep) (const $ map ((_ <> "b") <<< show <<< ArrayBuffer.byteLength) $ flip bind Rep.arrayBuffer $ Rep.clone rep) + liftEffect $ logTrace $ intercalate " " $ [ show status, statusText, repBodyDebug ] + + pure rep diff --git a/src/Gitea.Repo.BranchProtections.purs b/src/Gitea.Repo.BranchProtections.purs index 530533a..acae338 100644 --- a/src/Gitea.Repo.BranchProtections.purs +++ b/src/Gitea.Repo.BranchProtections.purs @@ -10,7 +10,8 @@ import Gitea.Auth as Auth import Gitea.Error as Error import Gitea.Trans (GiteaT) import Gitea.Types (BranchProtection, BranchProtectionName(..), BranchProtectionUpdate, RepoName(..), Username(..)) -import HTTP (Method(..), fetch) as HTTP +import Gitea.HTTP (fetch) as HTTP +import HTTP (Method(..)) as HTTP import HTTP.Request (json) as HTTP import Simple.JSON (class WriteForeign) import Type.Row.Subset (class Subset) @@ -23,16 +24,14 @@ branchProtectionOneURL (Username owner) (RepoName repo) (BranchProtectionName ru get :: forall m. MonadAff m => Username -> RepoName -> BranchProtectionName -> GiteaT m (Record BranchProtection) get u r b = do - { auth } <- ask url <- branchProtectionOneURL u r b - rep <- HTTP.fetch $ HTTP.GET /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.GET /\ url Error.tryGetRepJSON rep list :: forall m. MonadAff m => Username -> RepoName -> GiteaT m (Array (Record BranchProtection)) list u r = do - { auth } <- ask url <- branchProtectionURL u r - rep <- HTTP.fetch $ HTTP.GET /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.GET /\ url Error.tryGetRepJSON rep update @@ -46,14 +45,12 @@ update -> Record patch -> GiteaT m (Record BranchProtection) update u r b patch = do - { auth } <- ask url <- branchProtectionOneURL u r b - rep <- HTTP.fetch $ HTTP.PATCH /\ url /\ HTTP.json patch /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.PATCH /\ url /\ HTTP.json patch Error.tryGetRepJSON rep delete :: forall m. MonadAff m => Username -> RepoName -> BranchProtectionName -> GiteaT m Unit delete u r b = do - { auth } <- ask url <- branchProtectionOneURL u r b - rep <- HTTP.fetch $ HTTP.DELETE /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.DELETE /\ url Error.guardStatusOk rep diff --git a/src/Gitea.Repo.Secret.purs b/src/Gitea.Repo.Secret.purs index 874963c..4db090c 100644 --- a/src/Gitea.Repo.Secret.purs +++ b/src/Gitea.Repo.Secret.purs @@ -10,7 +10,8 @@ import Gitea.Auth as Auth import Gitea.Error as Error import Gitea.Trans (GiteaT) import Gitea.Types (RepoName(..), SecretName(..), Username(..)) -import HTTP (Method(..), fetch) as HTTP +import Gitea.HTTP (fetch) as HTTP +import HTTP (Method(..)) as HTTP import HTTP.Request (json) as HTTP secretsURL :: forall m. Monad m => Username -> RepoName -> SecretName -> GiteaT m URL @@ -18,14 +19,12 @@ secretsURL (Username owner) (RepoName repo) (SecretName secret) = (\{ baseURI } set :: forall m. MonadAff m => Username -> RepoName -> SecretName -> String -> GiteaT m Unit set u r s sv = do - { auth } <- ask url <- secretsURL u r s - rep <- HTTP.fetch $ HTTP.PUT /\ url /\ HTTP.json { "data": sv } /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.PUT /\ url /\ HTTP.json { "data": sv } Error.guardStatusOk rep remove :: forall m. MonadAff m => Username -> RepoName -> SecretName -> GiteaT m Unit remove u r s = do - { auth } <- ask url <- secretsURL u r s - rep <- HTTP.fetch $ HTTP.DELETE /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.DELETE /\ url Error.guardStatusOk rep diff --git a/src/Gitea.Repo.purs b/src/Gitea.Repo.purs index 4af103b..1043aa7 100644 --- a/src/Gitea.Repo.purs +++ b/src/Gitea.Repo.purs @@ -7,13 +7,15 @@ import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM) import Data.Array as Array import Data.Tuple.Nested ((/\)) import Data.URL (URL, (/), (?), (&)) +import Data.URL as URL import Effect.Aff.Class (class MonadAff) import Effect.Class (liftEffect) import Gitea.Auth as Auth import Gitea.Error as Error import Gitea.Trans (GiteaT) import Gitea.Types (OrgName(..), Repo, RepoName(..), RepoUpdate, TopicName(..), Username(..)) -import HTTP (Method(..), fetch) as HTTP +import Gitea.HTTP (fetch) as HTTP +import HTTP (Method(..)) as HTTP import HTTP.Request (json) as HTTP import Node.Buffer (Buffer) import Node.Buffer as Buffer @@ -42,9 +44,8 @@ orgReposURL (OrgName org) { page, limit } = (\{ baseURI } -> baseURI / "orgs" / get :: forall m. MonadAff m => Username -> RepoName -> GiteaT m (Record Repo) get owner repo = do - { auth } <- ask url <- reposURL owner repo - rep <- HTTP.fetch $ HTTP.GET /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.GET /\ url Error.tryGetRepJSON rep listForOrg :: forall m. MonadAff m => MonadRec m => OrgName -> GiteaT m (Array (Record Repo)) @@ -58,9 +59,8 @@ listForOrg o = paginate (repos /\ n) = maybeFetchMore repos n <$> getPage n getPage n = do - { auth } <- ask url <- orgReposURL o { limit, page: n } - rep <- HTTP.fetch $ HTTP.GET /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.GET /\ url Error.tryGetRepJSON rep in tailRecM paginate ([] /\ 1) @@ -75,38 +75,33 @@ update -> Record patch -> GiteaT m (Record Repo) update owner repo patch = do - { auth } <- ask url <- reposURL owner repo - rep <- HTTP.fetch $ HTTP.PATCH /\ url /\ HTTP.json patch /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.PATCH /\ url /\ HTTP.json patch Error.tryGetRepJSON rep delete :: forall m. MonadAff m => Username -> RepoName -> GiteaT m Unit delete owner repo = do - { auth } <- ask url <- reposURL owner repo - rep <- HTTP.fetch $ HTTP.DELETE /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.DELETE /\ url Error.guardStatusOk rep updateAvatar :: forall m. MonadAff m => Username -> RepoName -> Buffer -> GiteaT m Unit updateAvatar owner repo avatar = do - { auth } <- ask url <- map (_ / "avatar") $ reposURL owner repo b64 <- liftEffect $ Buffer.toString Base64 avatar - rep <- HTTP.fetch $ HTTP.POST /\ url /\ HTTP.json { image: b64 } /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.POST /\ url /\ HTTP.json { image: b64 } Error.guardStatusOk rep removeAvatar :: forall m. MonadAff m => Username -> RepoName -> GiteaT m Unit removeAvatar owner repo = do - { auth } <- ask url <- map (_ / "avatar") $ reposURL owner repo - rep <- HTTP.fetch $ HTTP.DELETE /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.DELETE /\ url Error.guardStatusOk rep addTopic :: forall m. MonadAff m => Username -> RepoName -> TopicName -> GiteaT m Unit addTopic owner repo topic = do - { auth } <- ask url <- repoTopicsOneURL owner repo topic - rep <- HTTP.fetch $ HTTP.PUT /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.PUT /\ url Error.guardStatusOk rep getTopics :: forall m. MonadAff m => MonadRec m => Username -> RepoName -> GiteaT m (Array TopicName) @@ -117,12 +112,12 @@ getTopics owner repo = maybeFetchMore topics n newTopics | Array.length newTopics < limit = Done $ topics <> newTopics | otherwise = Loop $ (topics <> newTopics) /\ (n + 1) + paginate (topics /\ n) = maybeFetchMore topics n <$> getPage n getPage n = do - { auth } <- ask url <- repoTopicsPageURL owner repo { limit, page: n } - rep <- HTTP.fetch $ HTTP.GET /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.GET /\ url { topics } <- Error.tryGetRepJSON @{ topics :: Array TopicName } rep pure topics in @@ -130,14 +125,12 @@ getTopics owner repo = removeTopic :: forall m. MonadAff m => Username -> RepoName -> TopicName -> GiteaT m Unit removeTopic owner repo topic = do - { auth } <- ask url <- repoTopicsOneURL owner repo topic - rep <- HTTP.fetch $ HTTP.DELETE /\ url /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.DELETE /\ url Error.guardStatusOk rep setTopics :: forall m. MonadAff m => Username -> RepoName -> Array TopicName -> GiteaT m Unit setTopics owner repo topics = do - { auth } <- ask url <- repoTopicsURL owner repo - rep <- HTTP.fetch $ HTTP.PUT /\ url /\ HTTP.json { topics } /\ Auth.headers auth + rep <- HTTP.fetch $ HTTP.PUT /\ url /\ HTTP.json { topics } Error.guardStatusOk rep