gitlab-haskell 0.1.2 → 0.1.3

raw patch · 9 files changed

+609/−180 lines, 9 filesdep +directorydep +filepathdep +mossdep ~aesondep ~http-conduitPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory, filepath, moss, temporary, time

Dependency ranges changed: aeson, http-conduit

API changes (from Hackage documentation)

Files

• app/Main.hs +315/−74
• gitlab-haskell.cabal +13/−5
• src/GitLab.hs +3/−1
• src/GitLab/API/Groups.hs +50/−26
• src/GitLab/API/Projects.hs +2/−2
• src/GitLab/API/RepositoryFiles.hs +20/−1
• src/GitLab/API/Todos.hs +11/−0
• src/GitLab/Types.hs +169/−68
• src/GitLab/WebRequests/GitLabWebCalls.hs +26/−3

@@ -4,6 +4,7 @@  import Control.Monad import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T@@ -11,6 +12,12 @@ import Network.HTTP.Types.Status import Data.Semigroup ((<>)) import Options.Applicative+import qualified Data.ByteString.Char8 as C+import Stanford.Moss+import Data.Maybe+import System.FilePath.Posix+import System.IO.Temp+import System.Directory  main :: IO () main = processOptions =<< execParser opts@@ -24,12 +31,19 @@   Options   { gitlabUrl :: String   , gitlabToken :: String-  , addUsersFilename :: String+  , usersFilename :: String   , group :: String   , project :: String   , addReportersToGroup :: Bool   , addGroupToProject :: Bool   , isRegistered :: Bool+  , plagiarism :: Bool+  , mossUserId :: String+  , mossLang :: String+  , plagiarismProject :: String+  , plagiarismFilePaths :: String+  , parentUser :: String+  , projectLinks :: Bool   }   deriving (Show) @@ -45,10 +59,10 @@     <> value ""     <> help "GitLab access token" )   <*> strOption-  ( long "filename"-    <> metavar "filename"+  ( long "userFilename"+    <> metavar "userFilename"     <> value ""-    <> help "name of a CSV file" )+    <> help "name of a CSV file with user IDs" )   <*> strOption   ( long "group"     <> metavar "group"@@ -68,83 +82,192 @@   <*> switch   ( long "registered"     <> help "prints 'yes' or 'no' depending on whether a user exists on the GitLab server" )+  <*> switch+  ( long "plagiarism"+    <> help "use MOSS to detect plagiarism" )+  <*> strOption+  ( long "mossUser"+    <> metavar "mossUser"+    <> value ""+    <> help "MOSS user ID" )+  <*> strOption+  ( long "mossLang"+    <> metavar "mossLang"+    <> value ""+    <> help "languge to pass to MOSS" )+  <*> strOption+  ( long "plagiarismProject"+    <> metavar "plagiarismProject"+    <> value ""+    <> help "project to detect plagiarism in" )+  <*> strOption+  ( long "plagiarismFiles"+    <> metavar "plagiarismFiles"+    <> value ""+    <> help "comma separated list of plagiarism files" )+  <*> strOption+  ( long "parent"+    <> metavar "parent"+    <> value ""+    <> help "parent username of skeleton code" )+  <*> switch+  ( long "projectLinks"+    <> help "get the URL links for searched for projects" )  processOptions :: Options -> IO ()-processOptions (Options _url _tok "" _grp _proj True _addGroup _isRegistered) =-  return ()-processOptions (Options _url _tok _filename "" _proj True _addGroup _isRegistered) =-  putStrLn "you must specify a group name too"-processOptions (Options _gUrl _gToken _fname _groupName _ True True _isRegistered) =-  putStrLn "you can only choose one of adding users to group or adding group to projects"---- add reporters to a group-processOptions (Options gUrl gToken fname groupName _ True False _isRegistered) = do-  text <- T.readFile fname-  let usernames = T.splitOn "," text-  runGitLab-    (defaultGitLabServer-      { url = T.pack gUrl-      , token = T.pack gToken-      })-    (addUsersToGroupDbg (T.pack groupName) Reporter usernames)-    --- add group as a member to all projects with a given name, as Reporter-processOptions (Options gUrl gToken _ groupName projectName False True _isRegistered) = do-  when (null groupName || null projectName)-    (error "for --share-project you must specify a group name and a project name")-  runGitLab-    (defaultGitLabServer-      { url = T.pack gUrl-      , token = T.pack gToken-      })-    (do groups <- groupsWithName (T.pack groupName)-        void $ liftIO $ when (null groups)-          (error ("group not found: " ++ groupName))-        void $ liftIO $ when (length groups > 1)-          (error ("multiple groups found for: " ++ groupName))-        -- should only be 1 group with this head-        let grp = head groups-        projects <- projectsWithName (T.pack projectName)-        mapM_-          (\prj -> do-             result <- shareProjectWithGroup (group_id grp) (project_id prj) Reporter-             case result of-               Left st -> liftIO (putStrLn ("unable to share project " ++ show (project_id prj) ++ " with group " ++ show (group_id grp) ++ ". Reason: " ++ show st))-               Right _details -> liftIO (putStrLn ("Added group " ++ show (group_id grp) ++ " to project " ++ show (project_id prj) ++ " as a Reporter"))-          )-          projects-    )---- ask if users are registered for a given GitLab server-processOptions (Options _gUrl _gToken "" __groupName _ False False True) =-  putStrLn "--registered needs a filename with --filename"-processOptions (Options gUrl gToken fname _groupName _ False False True) = do-  text <- T.readFile fname-  let usernames = T.splitOn "," text-  runGitLab-    (defaultGitLabServer-      { url = T.pack gUrl-      , token = T.pack gToken-      })-    (mapM_-      (\usrName ->-          do res <- searchUser usrName-             -- empty list of returned users-             if null res-             then liftIO $ putStrLn (T.unpack usrName ++ ": no")-             else liftIO $ putStrLn (T.unpack usrName ++ ": yes")-      )-      usernames-    )+processOptions opts = go+  where+    go+      | addReportersToGroup opts && usersFilename opts == "" = return ()+      | addReportersToGroup opts && group opts == "" =+        putStrLn "you must specify a group name too"+      | addReportersToGroup opts && addGroupToProject opts =+        putStrLn+          "you can only choose one of adding users to group or adding group to projects"+         -- add reporters to a group+      | addReportersToGroup opts && usersFilename opts /= "" = do+        text <- T.readFile (usersFilename opts)+        let usernames = T.splitOn "," text+        runGitLab+          (defaultGitLabServer+           {url = T.pack (gitlabUrl opts), token = T.pack (gitlabToken opts)})+          (addUsersToGroupDbg (T.pack (group opts)) Reporter usernames)+      | not (addReportersToGroup opts) &&+          addGroupToProject opts && null (group opts) && null (project opts) =+        error+          "for --share-project you must specify a group name and a project name"+       -- add group as a member to all projects with a given name, as Reporter+      | not (addReportersToGroup opts) && addGroupToProject opts =+        runGitLab+          (defaultGitLabServer+           {url = T.pack (gitlabUrl opts), token = T.pack (gitlabToken opts)})+          (do groups <- groupsWithNameOrPath (T.pack (group opts))+              void $+                liftIO $+                when (null groups) (error ("group not found: " ++ group opts))+              void $+                liftIO $+                when+                  (length groups > 1)+                  (error ("multiple groups found for: " ++ group opts))+               -- should only be 1 group with this head+              let grp = head groups+              projects <- projectsWithName (T.pack (project opts))+              mapM_+                (\prj -> do+                   result <-+                     shareProjectWithGroup+                       (group_id grp)+                       (project_id prj)+                       Reporter+                   case result of+                     Left st ->+                       liftIO+                         (putStrLn+                            ("unable to share project " +++                             show (project_id prj) +++                             " with group " +++                             show (group_id grp) ++ ". Reason: " ++ show st))+                     Right _details ->+                       liftIO+                         (putStrLn+                            ("Added group " +++                             show (group_id grp) +++                             " to project " +++                             show (project_id prj) ++ " as a Reporter")))+                projects)+       -- ask if users are registered for a given GitLab server+      | not (addReportersToGroup opts) &&+          not (addGroupToProject opts) && isRegistered opts =+        putStrLn "--registered needs a filename with --filename"+      | not (addReportersToGroup opts) &&+          not (addGroupToProject opts) &&+          isRegistered opts && usersFilename opts == "" =+        putStrLn "--registered needs a filename with --filename"+      | not (addReportersToGroup opts) &&+          not (addGroupToProject opts) && isRegistered opts = do+        text <- T.readFile (usersFilename opts)+        let usernames = T.splitOn "," text+        runGitLab+          (defaultGitLabServer+           {url = T.pack (gitlabUrl opts), token = T.pack (gitlabToken opts)})+          (mapM_+             (\usrName -> do+                res <- searchUser usrName+                      -- empty list of returned users+                if null res+                  then liftIO $ putStrLn (T.unpack usrName ++ ": no")+                  else liftIO $ putStrLn (T.unpack usrName ++ ": yes"))+             usernames)+      | plagiarism opts &&+          ((mossUserId opts == "") ||+           (mossLang opts == "") ||+           (plagiarismFilePaths opts == "") ||+           (plagiarismProject opts == "") ||+           (parentUser opts == "") || (usersFilename opts == "")) =+        putStrLn+          "--plagiarism needs a MOSS user, MOSS language, filepath list and a parent user"+      | plagiarism opts = do+        usersData <- readFile (usersFilename opts)+        let usernames = T.splitOn "," (T.pack usersData)+        let files = T.splitOn "," (T.pack (plagiarismFilePaths opts))+        runGitLab+          (defaultGitLabServer+           {url = T.pack (gitlabUrl opts), token = T.pack (gitlabToken opts)})+          (do reports <-+                runMoss+                  files+                  usernames+                  (T.pack (parentUser opts))+                  (T.pack (plagiarismProject opts))+                  (T.pack (mossUserId opts))+                  (T.pack (mossLang opts))+              liftIO (putStrLn "MOSS reports:")+              liftIO $ mapM_ T.putStr reports)+      | projectLinks opts && null (project opts) =+        error "--projectLinks must also be used with --project"+      | projectLinks opts = do+        usersData <- readFile (usersFilename opts)+        let usernames = T.splitOn "," (T.pack usersData)+        runGitLab+          (defaultGitLabServer+           {url = T.pack (gitlabUrl opts), token = T.pack (gitlabToken opts)})+          (mapM_+            (\username -> do+                projects <-+                  projectsWithNameAndUser username (T.pack (project opts))+                case projects of+                  Nothing -> return ()+                  Just proj -> do+                    isPassing <- projectCISuccess proj+                    numCommits <- projectCommits proj+                    liftIO $+                      putStrLn+                      (T.unpack (project_web_url proj) <> " (" <>+                        (if isPassing+                         then "passing, "+                         else "failing, ")+                        <> show (length numCommits) <> " commits)"))+                usernames)+      | otherwise = error "combination of flags not recognised" -processOptions Options{} =-  error "combination of flags not recognised"+{- add users -}    addUsersToGroupDbg ::-  (MonadIO m) => Text -> AccessLevel -> [Text] -> GitLab m ()+  (MonadIO m, MonadUnliftIO m) => Text -> AccessLevel -> [Text] -> GitLab m () addUsersToGroupDbg groupName access usernames = do+  (users :: [User]) <-+    catMaybes <$>+    mapM (\username ->+            do maybeUser <- searchUser username+               case maybeUser of+                 Nothing -> do+                   liftIO $ putStrLn $ T.unpack username <> " not found on server."+                   return Nothing+                 u -> return u+         ) usernames   (results :: [Either Status Member]) <--    addUsersToGroup groupName access usernames+    addUsersToGroup groupName access users   liftIO $ mapM_     (\(result :: Either Status Member) ->        case result of@@ -154,3 +277,121 @@              ("Added to " ++               show groupName ++ ": " ++ show (member_username member)))     results++{- plagiarism detection -}++runMoss :: (MonadIO m, MonadUnliftIO m) => [Text] -> [Text] -> Text -> Text -> Text -> Text -> GitLab m [Text]+runMoss filepaths usernames skeletonUser projectName mossUserKey lang =+  mapM+    (\fpath -> do+       liftIO $ putStrLn ("Processing file " ++ T.unpack fpath ++ "\n")+       liftIO $+         putStrLn+           ("getting handed out code " +++            T.unpack skeletonUser ++ "/" ++ T.unpack projectName ++ "\n")+       skeletonCode <-+         fromJust <$> getCode fpath "master" skeletonUser projectName+       userSubmissions <-+         mapM+           (\usr -> do+              liftIO+                (putStrLn+                   ("getting " ++ T.unpack fpath ++ " from " +++                    T.unpack usr ++ "/" ++ T.unpack projectName))+              maybe_userCode <- getCode fpath "master" usr projectName+              case maybe_userCode of+                Nothing -> return Nothing+                Just userCode -> return (Just (usr, userCode)))+           usernames+       liftIO (putStrLn "sending job to moss")+       result <- moss fpath skeletonCode (catMaybes userSubmissions) mossUserKey lang+       liftIO $ putStrLn ("File " ++ T.unpack fpath ++ " processed.\n")+       return result+    )+    filepaths++moss :: (MonadIO m, MonadUnliftIO m) => Text -> Text -> [(Text,Text)] -> Text -> Text -> GitLab m Text+moss skeletonFilename skeletonData studentCode mossUserKey lang = do+  let language =+        case T.unpack lang of+          "C" -> C+          "CPP" -> CPP+          "Java" -> Java+          "CSharp" -> CSharp+          "Python" -> Python+          "VisualBasic" -> VisualBasic+          "Javascript" -> Javascript+          "FORTRAN" -> FORTRAN+          "ML" -> ML+          "Haskell" -> Haskell+          "Lisp" -> Lisp+          "Scheme" -> Scheme+          "Pascal" -> Pascal+          "Modula2" -> Modula2+          "Ada" -> Ada+          "Perl" -> Perl+          "TCL" -> TCL+          "Matlab" -> Matlab+          "VHDL" -> VHDL+          "Verilog" -> Verilog+          _ -> error "unrecognised MOSS language name"+  let ext =+        case T.unpack lang of+          "C" -> ".c"+          "CPP" -> ".cpp"+          "Java" -> ".java"+          "CSharp" -> ".cs"+          "Python" -> ".py"+          "VisualBasic" -> ".vb"+          "Javascript" -> ".js"+          "FORTRAN" -> ".f"+          "ML" -> ".ml"+          "Haskell" -> ".hs"+          "Lisp" -> ".lisp"+          "Scheme" -> ".scm"+          "Pascal" -> ".pas"+          "Modula2" -> ".mod"+          "Ada" -> ".ada"+          "Perl" -> ".pl"+          "TCL" -> ".tcl"+          "Matlab" -> ".m"+          "VHDL" -> ".vhdl"+          "Verilog" -> ".v"+          _ -> error "unrecognised MOSS language name"        +  let cfg :: MossCfg+      cfg = defaultMossCfg {+        mossLanguage = language+        , mossUser = C.pack (T.unpack mossUserKey)+        }+  tmpSkelFile <- liftIO $ writeSystemTempFile (takeFileName (T.unpack skeletonFilename)) (T.unpack skeletonData)+  userFiles <- mapM (\(userId,code) -> do+                        userFile <- liftIO $ writeSystemTempFile (T.unpack userId <> ext) (T.unpack code)+                        return (userFile,userId)+                    )+               studentCode+  liftIO $ withMoss cfg $ do+    addBaseFile "Skeleton" tmpSkelFile+    mapM_ (\(userFile,userId) ->+           addFile (T.unpack userId) userFile+          ) userFiles+    res <- fromJust <$> query (C.pack ("moss-" <> takeFileName (T.unpack skeletonFilename)))++    -- remove temporary files+    liftIO $ removeFile tmpSkelFile+    liftIO $ mapM_ (\(fileName,_) -> removeFile fileName) userFiles+    +    return (T.pack (C.unpack res))++getCode :: (MonadIO m, MonadUnliftIO m) => Text -> Text -> Text -> Text -> GitLab m (Maybe Text)+getCode filepath branch username projectName = do+    maybe_proj <- projectsWithNameAndUser username projectName+    case maybe_proj of+      Nothing -> return Nothing+      Just proj -> do+        maybe_file <- repositoryFiles proj filepath branch+        case maybe_file of+          Nothing -> error "repo file not found"+          Just repoFile -> do+            let blobHash = blob_id repoFile+            contents <- repositoryFileBlob (project_id proj) blobHash+            return (Just (T.pack contents))

@@ -1,14 +1,14 @@ cabal-version: 2.4 name:           gitlab-haskell category:       Git-version:        0.1.2+version:        0.1.3 synopsis:       A Haskell library for the GitLab web API description:   This Haskell library queries and updates the database of a GitLab instance using the GitLab web API: <https://docs.gitlab.com/ee/api/>   .   Unsurprisingly, GitLab hosts this Haskell library: <https://gitlab.com/robstewart57/gitlab-haskell>- -                ++ homepage:       https://gitlab.com/robstewart57/gitlab-haskell bug-reports:    https://gitlab.com/robstewart57/gitlab-haskell/issues author:         Rob Stewart@@ -35,6 +35,12 @@               , text               , http-types               , optparse-applicative+              , bytestring+              , moss+              , filepath+              , unliftio-core+              , temporary+              , directory   default-language: Haskell2010  library@@ -53,19 +59,21 @@                 , GitLab.API.Repositories                 , GitLab.API.MergeRequests                 , GitLab.API.RepositoryFiles+                , GitLab.API.Todos                 , GitLab.WebRequests.GitLabWebCalls   hs-source-dirs:                  src   build-depends:                 base >=4.7 && <5-              , http-conduit >= 2.3.4+              , http-conduit               , connection-              , aeson+              , aeson >= 1.4.4.0               , bytestring               , text               , http-types               , transformers               , unliftio               , unliftio-core+              , time   default-language: Haskell2010   ghc-options: -Wall

@@ -1,7 +1,7 @@  {-| Module      : GitLab-Description : Contains the 'runGitLab' function to run GitLab actions +Description : Contains the 'runGitLab' function to run GitLab actions Copyright   : (c) Rob Stewart, Heriot-Watt University, 2019 License     : BSD3 Maintainer  : robstewart57@gmail.com@@ -22,6 +22,7 @@   , module GitLab.API.MergeRequests   , module GitLab.API.Repositories   , module GitLab.API.RepositoryFiles+  , module GitLab.API.Todos   ) where  import Control.Monad.IO.Class@@ -42,6 +43,7 @@ import GitLab.API.Projects import GitLab.API.Repositories import GitLab.API.RepositoryFiles+import GitLab.API.Todos import GitLab.API.Users import GitLab.Types 

@@ -16,37 +16,43 @@ import Data.Maybe import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Network.HTTP.Types.Status+import Network.HTTP.Types.URI+import qualified Data.ByteString.Char8 as C  import GitLab.API.Members import GitLab.API.Users import GitLab.Types import GitLab.WebRequests.GitLabWebCalls --- | gets groups with the given group name.+-- | gets groups with the given group name or path. ----- > projectsWithName "group1"-groupsWithName :: (MonadUnliftIO m, MonadIO m)+-- > projectsWithNameOrPath "group1"+groupsWithNameOrPath :: (MonadUnliftIO m, MonadIO m)   => Text -- ^ group name being searched for.   -> GitLab m [Group]-groupsWithName groupName =-  filter (\group -> groupName == group_path group) <$>+groupsWithNameOrPath groupName =+  filter (\group ->+            groupName == group_name group+            || groupName == group_path group+         ) <$>   gitlabWithAttrs "/groups" ("&search=" <> groupName)  -- | adds all registered users to a group. addAllUsersToGroup ::-     (MonadIO m)+     (MonadIO m, MonadUnliftIO m)   => Text -- ^ group name   -> AccessLevel -- ^ level of access granted   -> GitLab m [Either Status Member] addAllUsersToGroup groupName access = do   allRegisteredUsers <- allUsers   let allUserIds = map user_username allRegisteredUsers-  addUsersToGroup groupName access allUserIds+  addUsersToGroup' groupName access allUserIds  -- | adds a user to a group. addUserToGroup ::-     (MonadIO m)+     (MonadIO m, MonadUnliftIO m)   => Text -- ^ group name   -> AccessLevel -- ^ level of access granted   -> User -- ^ the user@@ -54,29 +60,47 @@ addUserToGroup groupName access usr =   addUserToGroup' groupName access (user_id usr) +-- | adds a user with a given user ID to a group.+addUserToGroup' ::+     (MonadIO m, MonadUnliftIO m)+  => Text -- ^ group name+  -> AccessLevel -- ^ level of access granted+  -> Int -- ^ user ID+  -> GitLab m (Either Status Member)+addUserToGroup' groupName access userId = do+  groups <- groupsWithNameOrPath groupName+  case groups of+    [] -> return (Left (mkStatus 404 (C.pack "cannot find group")))+    [grp] ->+      gitlabPost addr dataBody+      where+        dataBody :: Text+        dataBody =+          "user_id=" <> T.pack (show userId) <> "&access_level=" <>+          T.pack (show access)+        addr = "/groups/"+               <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 (T.pack (show (group_id grp)))))+               <> "/members"+    (_:_) ->+      return (Left (mkStatus 404 (C.pack "too many groups found")))+ -- | adds a list of users to a group. addUsersToGroup ::-     (MonadIO m)+     (MonadIO m, MonadUnliftIO m)   => Text -- ^ group name   -> AccessLevel -- ^ level of access granted-  -> [Text] -- ^ list of usernames to be added to the group+  -> [User] -- ^ list of usernames to be added to the group   -> GitLab m [Either Status Member]-addUsersToGroup groupName access usernames = do-  users <- catMaybes <$> mapM searchUser usernames-  mapM (addUserToGroup' groupName access . user_id) users+addUsersToGroup groupName access =+  mapM (addUserToGroup groupName access) --- | adds a user with a given user ID to a group.-addUserToGroup' ::-     (MonadIO m)+-- | adds a list of users to a group.+addUsersToGroup' ::+     (MonadIO m, MonadUnliftIO m)   => Text -- ^ group name   -> AccessLevel -- ^ level of access granted-  -> Int -- ^ user ID-  -> GitLab m (Either Status Member)-addUserToGroup' groupName access userId = gitlabPost addr dataBody-  where-    dataBody :: Text-    dataBody =-      "user_id=" <> T.pack (show userId) <> "&access_level=" <>-      T.pack (show access)-    addr = "/groups/" <> groupName <> "/members"-+  -> [Text] -- ^ list of usernames to be added to the group+  -> GitLab m [Either Status Member]+addUsersToGroup' groupName access usernames = do+  users <- catMaybes <$> mapM searchUser usernames+  mapM (addUserToGroup' groupName access . user_id) users

@@ -206,8 +206,8 @@  -- | gets all diffs in a project for a given commit SHA. projectDiffs :: (MonadIO m) => Project -> Text -> GitLab m [Diff]-projectDiffs proj commitSha =-  projectDiffs' (project_id proj) commitSha+projectDiffs proj =+  projectDiffs' (project_id proj)  -- | gets all diffs in a project for a given project ID, for a given -- commit SHA.

@@ -13,6 +13,8 @@ import Control.Monad.IO.Unlift import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Types.URI  import GitLab.Types import GitLab.WebRequests.GitLabWebCalls@@ -41,4 +43,21 @@       <> "/repository"       <> "/files"       <> "/"-      <> filePath+      <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 filePath))+      -- <> filePath++-- | Get raw data for a given file blob hash.+repositoryFileBlob :: (MonadIO m)+  => Int -- ^ project ID+  -> Text -- ^ blob SHA+  -> GitLab m String+repositoryFileBlob projectId blobSha =+  gitlabReqText addr+  where+    addr =+      "/projects/"+      <> T.pack (show projectId)+      <> "/repository"+      <> "/blobs/"+      <> blobSha+      <> "/raw"

@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}++module GitLab.API.Todos where++import Control.Monad.IO.Class+import GitLab.Types+import GitLab.WebRequests.GitLabWebCalls++-- | returns all pending todos for the user, as defined by the access token.+todos :: (MonadIO m) => GitLab m [Todo]+todos = gitlab "/todos"

@@ -1,5 +1,7 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}  {-| Module      : GitLab.Types@@ -38,18 +40,25 @@   , Branch(..)   , RepositoryFile(..)   , MergeRequest(..)+  , Todo(..)+  , TodoAction(..)+  , TodoTarget(..)+  , TodoState(..)+  , URL   ) where +import Control.Monad.Trans.Reader import Data.Aeson+import Data.Aeson.Types import Data.Text (Text)+import Data.Time.Clock import GHC.Generics import Network.HTTP.Conduit-import Control.Monad.Trans.Reader  -- | type synonym for all GitLab actions. type GitLab m a = ReaderT GitLabState m a --- | state used by GitLab actions, used internally. +-- | state used by GitLab actions, used internally. data GitLabState =   GitLabState   { serverCfg :: GitLabServerConfig@@ -97,7 +106,7 @@   , kind :: Text   , full_path :: Text   , parent_id :: Maybe Text-  } deriving (Generic, Show, Eq)+  } deriving (Generic, Show)  -- | links. data Links =@@ -109,7 +118,7 @@   , link_labels :: Text   , link_events :: Text   , members :: Text-  } deriving (Generic, Show, Eq)+  } deriving (Generic, Show)  -- | owners. data Owner =@@ -120,14 +129,14 @@   , state :: Text   , owner_avatar_url :: Maybe Text   , owner_web_url :: Text-  } deriving (Generic, Show, Eq)+  } deriving (Generic, Show)  -- | permissions. data Permissions =   Permissions   { project_access :: Maybe Object   , group_access :: Maybe Object-  } deriving (Generic, Show, Eq)+  } deriving (Generic, Show)  -- | projects. data Project =@@ -177,7 +186,7 @@   , merge_method:: Maybe Text   , permissions :: Maybe Permissions   , project_stats :: Maybe ProjectStats-  } deriving (Generic, Show, Eq)+  } deriving (Generic, Show)  data ProjectStats =   ProjectStats@@ -188,7 +197,7 @@   , lfs_objects_size :: Maybe Int   , job_artifacts_size :: Maybe Int   , packages_size :: Maybe Int-  } deriving (Generic, Show, Eq)+  } deriving (Generic, Show)  -- | registered users. data User =@@ -199,21 +208,33 @@   , user_state :: Text   , user_avatar_uri :: Maybe Text   , user_web_url :: Maybe Text-  } deriving (Generic, Show, Eq)+  } deriving (Generic, Show) --- | project milestones.+-- | milestones.+data MilestoneState = MSActive+                    | MSClosed+                    deriving (Show)+instance FromJSON MilestoneState where+  parseJSON (String "active") = return MSActive+  parseJSON (String "closed") = return MSClosed+  parseJSON x = unexpected x+ data Milestone =   Milestone-  { milestone_project_id :: Int+  { milestone_project_id :: Maybe Int+  , milestone_group_id :: Maybe Int   , milestone_description :: Text-  , milestone_state :: Text-  , due_date :: Maybe Text+  , milestone_state :: MilestoneState+  , milestone_due_date :: Maybe UTCTime   , milestone_iid :: Int-  , milestone_created_at :: Maybe Text+  , milestone_created_at :: Maybe UTCTime   , milestone_title :: Text   , milestone_id :: Int-  , milestone_updated_at :: Text-  } deriving (Generic, Show, Eq)+  , milestone_updated_at :: UTCTime+  , milestone_web_url :: URL+  } deriving (Generic, Show)+instance FromJSON Milestone where+  parseJSON = genericParseJSON (defaultOptions { fieldLabelModifier = drop 10 })  -- | time stats. data TimeStats =@@ -222,7 +243,7 @@   , total_time_spent :: Int   , humane_time_estimate :: Maybe Int   , human_total_time_spent :: Maybe Int-  } deriving (Generic, Show, Eq)+  } deriving (Generic, Show)  -- | project issues. data Issue =@@ -251,7 +272,7 @@   , weight :: Maybe Text -- Int?   , discussion_locked :: Maybe Bool   , time_stats :: TimeStats-  } deriving (Generic, Show, Eq)+  } deriving (Generic, Show)  -- | project pipelines data Pipeline =@@ -283,6 +304,15 @@   , commit_status :: Maybe Text   } deriving (Generic, Show) +-- | summary of a code commit for TODOs.+data CommitTodo =+  CommitTodo+  { todo_commit_id :: Text+  , todo_commit_short_id :: Text+  , todo_commit_created_at :: Text+  , todo_parent_ids :: Maybe [Text]+  } deriving (Generic, Show)+ -- | commit stats. data CommitStats =   Stats@@ -365,7 +395,6 @@   , group_parent_id :: Maybe Int   } deriving (Generic, Show) -   -- | response to sharing a project with a group. data GroupShare =   GroupShare@@ -446,61 +475,135 @@   , merge_request_approvals_before_merge :: Maybe Bool -- ?   } deriving (Generic, Show) ++data TodoAction = TAAssigned+                | TAMentioned+                | TABuildFailed+                | TAMarked+                | TAApprovalRequired+                | TAUnmergeable+                | TADirectlyAddressed+                deriving (Show)+instance FromJSON TodoAction where+  parseJSON (String "assigned") = return TAAssigned+  parseJSON (String "mentioned") = return TAMentioned+  parseJSON (String "build_failed") = return TABuildFailed+  parseJSON (String "marked") = return TAMarked+  parseJSON (String "approval_required") = return TAApprovalRequired+  parseJSON (String "unmergeable") = return TAUnmergeable+  parseJSON (String "directly_addressed") = return TADirectlyAddressed+  parseJSON x = unexpected x++data TodoTarget = TTIssue Issue+                | TTMergeRequest MergeRequest+                | TTCommit CommitTodo+                deriving (Show)++type URL = Text++data TodoState = TSPending+               | TSDone+               deriving (Show)+instance FromJSON TodoState where+  parseJSON (String "pending") = return TSPending+  parseJSON (String "done") = return TSDone+  parseJSON x = unexpected x++data TodoProject = TP { tp_id :: Int+                      , tp_description :: Text+                      , tp_name :: Text+                      , tp_name_with_namespace :: Text+                      , tp_path :: Text+                      , tp_path_with_namespace :: Text+                      , tp_created_at :: UTCTime }+                 deriving (Generic, Show)+instance FromJSON TodoProject where+  parseJSON = genericParseJSON (defaultOptions { fieldLabelModifier = drop 3 })++data Todo = Todo { todo_id :: Int+                 , todo_project :: TodoProject+                 , todo_author :: User+                 , todo_action_name :: TodoAction+                 , todo_target :: TodoTarget+                 , todo_target_url :: URL+                 , todo_body :: Text+                 , todo_state :: TodoState+                 , todo_created_at :: UTCTime }+          deriving (Show)+instance FromJSON Todo where+  parseJSON = withObject "Todo" $ \v -> Todo+    <$> v .: "id"+    <*> v .: "project"+    <*> v .: "author"+    <*> v .: "action_name"+    <*> (v .: "target_type" >>= \case+      "MergeRequest" -> TTMergeRequest <$> v .: "target"+      "Issue" -> TTIssue <$> v .: "target"+      "Commit" -> TTCommit <$> v .: "target"+      (_ :: Text) -> fail "" )+    <*> v .: "target_url"+    <*> v .: "body"+    <*> v .: "state"+    <*> v .: "created_at"+ ----------------------------- -- JSON GitLab parsers below -----------------------------  bodyNoPrefix :: String -> String-bodyNoPrefix "project_id" = "id"-bodyNoPrefix "namespace_id" = "id"-bodyNoPrefix "owner_id" = "id"-bodyNoPrefix "user_id" = "id"-bodyNoPrefix "repository_id" = "id"-bodyNoPrefix "project_name" = "name"-bodyNoPrefix "repository_name" = "name"-bodyNoPrefix "project_path" = "path"-bodyNoPrefix "namespace_name" = "name"-bodyNoPrefix "user_name" = "name"-bodyNoPrefix "namespace_path" = "path"-bodyNoPrefix "owner_name" = "name"-bodyNoPrefix "owner_avatar_url" = "avatar_url"-bodyNoPrefix "user_avatar_url" = "avatar_url"-bodyNoPrefix "owner_web_url" = "web_url"+bodyNoPrefix "commit_created_at" = "created_at"+bodyNoPrefix "commit_id" = "id"+bodyNoPrefix "commit_status" = "status"+bodyNoPrefix "todo_commit_id" = "id"+bodyNoPrefix "todo_commit_short_id" = "short_id"+bodyNoPrefix "todo_commit_created_at" = "created_at"+bodyNoPrefix "todo_parent_ids" = "parent_ids"+bodyNoPrefix "issue_author" = "author"+bodyNoPrefix "issue_created_at" = "created_at"+bodyNoPrefix "issue_description" = "description"+bodyNoPrefix "issue_due_date" = "due_date"+bodyNoPrefix "issue_id" = "id"+bodyNoPrefix "issue_labels" = "labels"+bodyNoPrefix "issue_project_id" = "project_id"+bodyNoPrefix "issue_state" = "state"+bodyNoPrefix "issue_title" = "title"+bodyNoPrefix "issue_web_url" = "web_url" bodyNoPrefix "job_web_url" = "web_url"-bodyNoPrefix "project_avatar_url" = "avatar_url"-bodyNoPrefix "project_web_url" = "web_url"+bodyNoPrefix "link_events" = "events"+bodyNoPrefix "link_labels" = "labels"+bodyNoPrefix "member_avatar_url" = "avatar_url" bodyNoPrefix "member_id" = "id" bodyNoPrefix "member_name" = "name"-bodyNoPrefix "member_avatar_url" = "avatar_url"-bodyNoPrefix "member_web_url" = "we_url"-bodyNoPrefix "user_web_url" = "we_url"+bodyNoPrefix "member_state" = "state" bodyNoPrefix "member_username" = "username"+bodyNoPrefix "member_web_url" = "we_url"+bodyNoPrefix "namespace_id" = "id"+bodyNoPrefix "namespace_name" = "name"+bodyNoPrefix "namespace_path" = "path"+bodyNoPrefix "owner_avatar_url" = "avatar_url"+bodyNoPrefix "owner_id" = "id"+bodyNoPrefix "owner_name" = "name" bodyNoPrefix "owner_username" = "username"-bodyNoPrefix "user_username" = "username"+bodyNoPrefix "owner_web_url" = "web_url" bodyNoPrefix "pipeline_id" = "id"-bodyNoPrefix "pipeline_web_url" = "web_url"-bodyNoPrefix "commit_id" = "id"-bodyNoPrefix "member_state" = "state"-bodyNoPrefix "user_state" = "state"-bodyNoPrefix "issue_state" = "state"-bodyNoPrefix "issue_description" = "description"-bodyNoPrefix "issue_author" = "author"-bodyNoPrefix "issue_project_id" = "project_id"-bodyNoPrefix "issue_id" = "id"-bodyNoPrefix "issue_title" = "title"-bodyNoPrefix "issue_due_date" = "due_date"-bodyNoPrefix "issue_web_url" = "web_url"-bodyNoPrefix "commit_status" = "status" bodyNoPrefix "pipeline_status" = "status"-bodyNoPrefix "issue_labels" = "labels"-bodyNoPrefix "link_labels" = "labels"-bodyNoPrefix "issue_created_at" = "created_at"-bodyNoPrefix "commit_created_at" = "created_at"+bodyNoPrefix "pipeline_web_url" = "web_url"+bodyNoPrefix "project_avatar_url" = "avatar_url" bodyNoPrefix "project_created_at" = "created_at"-bodyNoPrefix "milestone_created_at" = "created_at"-bodyNoPrefix "link_events" = "events"-bodyNoPrefix "repository_type" = "type"+bodyNoPrefix "project_id" = "id"+bodyNoPrefix "project_name" = "name"+bodyNoPrefix "project_path" = "path"+bodyNoPrefix "project_web_url" = "web_url"+bodyNoPrefix "repository_id" = "id"+bodyNoPrefix "repository_name" = "name" bodyNoPrefix "repository_path" = "path"+bodyNoPrefix "repository_type" = "type"+bodyNoPrefix "user_avatar_url" = "avatar_url"+bodyNoPrefix "user_id" = "id"+bodyNoPrefix "user_name" = "name"+bodyNoPrefix "user_state" = "state"+bodyNoPrefix "user_username" = "username"+bodyNoPrefix "user_web_url" = "we_url"  bodyNoPrefix "event_title" = "title" bodyNoPrefix "event_project_id" = "project_id"@@ -576,8 +679,6 @@ bodyNoPrefix "group_full_path" = "full_path" bodyNoPrefix "group_file_template_project_id" = "file_template_project_id" bodyNoPrefix "group_parent_id" = "parent_id"-- -- TODO field names for Issues data type bodyNoPrefix s = s @@ -586,22 +687,22 @@               (defaultOptions                { fieldLabelModifier = bodyNoPrefix }) -instance FromJSON Milestone where+instance FromJSON Issue where   parseJSON = genericParseJSON               (defaultOptions                { fieldLabelModifier = bodyNoPrefix }) -instance FromJSON Issue where+instance FromJSON User where   parseJSON = genericParseJSON               (defaultOptions                { fieldLabelModifier = bodyNoPrefix }) -instance FromJSON User where+instance FromJSON Commit where   parseJSON = genericParseJSON               (defaultOptions                { fieldLabelModifier = bodyNoPrefix }) -instance FromJSON Commit where+instance FromJSON CommitTodo where   parseJSON = genericParseJSON               (defaultOptions                { fieldLabelModifier = bodyNoPrefix })

@@ -9,6 +9,7 @@   , gitlabOne   , gitlabWithAttrsOne   , gitlabPost+  , gitlabReqText   ) where  import Network.HTTP.Conduit@@ -22,6 +23,8 @@ import GitLab.Types import Control.Monad.Trans.Reader import Control.Monad.IO.Class+import Data.ByteString.Lazy.Char8 as C+import Network.HTTP.Types.URI  gitlabPost ::   (MonadIO m, FromJSON b) =>@@ -89,7 +92,7 @@             <> "?per_page=100"             <> "&page="             <> T.pack (show i)-            <> attrs+            <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 attrs))       let request' = parseRequest_ (T.unpack url')           request = request'             { requestHeaders =@@ -104,8 +107,7 @@       else go (i+1) accum'  gitlabReqOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Maybe a)-gitlabReqOne urlPath attrs = do-  go+gitlabReqOne urlPath attrs = go   where     go = do       cfg <- serverCfg <$> ask@@ -125,6 +127,27 @@             }       res <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing       return (parseBSOne (responseBody res))++gitlabReqText :: (MonadIO m) => Text -> GitLab m String+gitlabReqText urlPath = go+  where+    go = do+      cfg <- serverCfg <$> ask+      manager <- httpManager <$> ask+      let url' =+               url cfg+            <> "/api/v4"+            <> urlPath+            <> "?per_page=100"+            <> "&page=1"+      let request' = parseRequest_ (T.unpack url')+          request = request'+            { requestHeaders =+              [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))]+            , responseTimeout = responseTimeoutMicro (timeout cfg)+            }+      res <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing+      return (C.unpack (responseBody res))  gitlab :: (MonadIO m, FromJSON a) => Text -> GitLab m [a] gitlab addr = gitlabReq addr ""