kazbek/tea-cleaner/TeaCleaner/Client.hs

{- This Source Code Form is subject to the terms of the Mozilla Public License,
   v. 2.0. If a copy of the MPL was not distributed with this file, You can
   obtain one at https://mozilla.org/MPL/2.0/. -}

module TeaCleaner.Client
    ( Activity(..)
    , User(..)
    , getActivities
    , getUsers
    , purgeUser
    ) where

import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (StrictText)
import qualified Data.Text.Encoding as Text.Encoding
import Data.Vector (Vector)
import qualified Text.URI as URI
import qualified Text.URI.QQ as URI
import Network.HTTP.Req
    ( DELETE(..)
    , GET(..)
    , NoReqBody(..)
    , HttpMethod(..)
    , HttpBody
    , HttpResponse(..)
    , HttpBodyAllowed
    , ProvidesBody
    , defaultHttpConfig
    , ignoreResponse
    , jsonResponse
    , oAuth2Bearer
    , responseBody
    , req
    , runReq
    , useHttpsURI
    )
import GHC.Records (HasField(..))
import TeaCleaner.Options (jsonOptions)
import Data.Int (Int64)
import qualified Data.Aeson.TH as Aeson
import Data.Time (ZonedTime(..))
import TeaCleaner.Configuration (Settings(..))
import Data.Data (Proxy)
import Text.URI (URI)

data User = User
    { id :: Int64
    , login :: StrictText
    , loginName :: StrictText
    , fullName :: StrictText
    , email :: StrictText
    , avatarUrl :: StrictText
    , language :: StrictText
    , isAdmin :: Bool
    , lastLogin :: ZonedTime
    , created :: ZonedTime
    , restricted :: Bool
    , active :: Bool
    , prohibitLogin :: Bool
    , location :: StrictText
    , website :: StrictText
    , description :: StrictText
    , visibility :: StrictText
    , followersCount :: Int
    , followingCount :: Int
    , starredReposCount :: Int
    , username :: StrictText
    } deriving (Show)

$(Aeson.deriveJSON jsonOptions ''User)

data Activity = Activity
    { actUserId :: Int64
    -- , comment Comment
    , commentId :: Int64
    , content :: StrictText
    , created :: ZonedTime
    , id :: Int64
    , isPrivate :: Bool
    , opType :: StrictText
    , refName :: StrictText
    -- repo	Repository{...}
    , repoId :: Int64
    , userId :: Int64
    } deriving (Show)

$(Aeson.deriveJSON jsonOptions ''Activity)

purgeUser :: Settings -> User -> IO ()
purgeUser Settings{..} user =
    let pathConstructor lastPiece = [URI.pathPiece|api|] :|
            [ [URI.pathPiece|v1|]
            , [URI.pathPiece|admin|]
            , [URI.pathPiece|users|]
            , lastPiece
            ]
        uri = server
            { URI.uriPath = (False,) . pathConstructor
                <$> URI.mkPathPiece (getField @"username" user)
            , URI.uriQuery = [URI.QueryParam [URI.queryKey|purge|] [URI.queryValue|true|]]
            }
     in doRequest uri token DELETE NoReqBody ignoreResponse

getActivities :: Settings -> User -> IO (Vector Activity)
getActivities Settings{..} user =
    let pathConstructor lastPiece = [URI.pathPiece|api|] :|
            [ [URI.pathPiece|v1|]
            , [URI.pathPiece|users|]
            , lastPiece
            , [URI.pathPiece|activities|]
            , [URI.pathPiece|feeds|]
            ]
        uri = server
            { URI.uriPath = (False,) . pathConstructor
                <$> URI.mkPathPiece (getField @"username" user)
            , URI.uriQuery = [URI.QueryParam [URI.queryKey|purge|] [URI.queryValue|true|]]
            }
     in doRequest uri token GET NoReqBody jsonResponse

getUsers :: Settings -> IO (Vector User)
getUsers Settings{..} =
    let pathPieces = [URI.pathPiece|api|] :|
            [ [URI.pathPiece|v1|]
            , [URI.pathPiece|admin|]
            , [URI.pathPiece|users|]
            ]
        uri = server
            { URI.uriPath = Just (False, pathPieces)
            }
     in doRequest uri token GET NoReqBody jsonResponse

doRequest
    :: (HttpMethod method, HttpBody body, HttpResponse response, HttpBodyAllowed (AllowsBody method) (ProvidesBody body))
    => URI -> StrictText -> method -> body -> Proxy response -> IO (HttpResponseBody response)
doRequest uri token method body response =
    case useHttpsURI uri of
        Just (httpsURI, httpsOptions) -> fmap responseBody
            $ runReq defaultHttpConfig
            $ req method httpsURI body response
            $ httpsOptions <> oAuth2Bearer (Text.Encoding.encodeUtf8 token)
        Nothing -> error "Invalid https URI"