Partial escape in query string to make search work again

github.cabal

@@ -155,7 +155,7 @@ Library
     deepseq-generics      >=0.1.1.2   && <0.3,
     exceptions            >=0.8.0.2   && <0.11,
     hashable              >=1.2.3.3   && <1.3,
-    http-client           >=0.4.8.1   && <0.6,
+    http-client           >=0.5.10    && <0.6,
     http-client-tls       >=0.2.2     && <0.4,
     http-link-header      >=1.0.1     && <1.1,
     http-types            >=0.12.1    && <0.13,

samples/Search/AllHaskellRepos.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE OverloadedStrings #-}
+module AllHaskellRepos where
+import           Control.Monad(when)
+import           Data.List(group, sort)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified Data.Vector as V
+import           Data.Time.Calendar(addDays, Day(..), showGregorian)
+import           Data.Time.Clock(getCurrentTime, UTCTime(..))
+import           Data.Time.Format(parseTimeM, defaultTimeLocale, iso8601DateFormat)
+import           Time.System(dateCurrent)
+import           GitHub.Auth(Auth(..))
+import           GitHub.Endpoints.Search(searchRepos', SearchResult(..), EscapeItem(..),
+                                         searchIssues')
+import           GitHub.Data.Repos
+import           GitHub.Data.Definitions
+import           GitHub.Data.Name
+import           GitHub.Data.URL
+import           GitHub.Data.Options(SearchRepoMod(..), SearchRepoOptions(..), Language(..),
+                                     License(..), StarsForksUpdated(..), SortDirection(..),
+                                     searchRepoModToQueryString)
+import           System.FilePath.Posix(FilePath)
+import Debug.Trace
+
+-- | A search query finds all Haskell libraries on github
+--   and updates two files of all packages/authors
+updateGithub :: [FilePath] -> IO ()
+updateGithub [lastIntervalEnd, authorsCsv, packagesCsv] = do
+  lastEnd <- T.readFile lastIntervalEnd -- first time: 2008-03-01
+  start <- parseTimeM True defaultTimeLocale (iso8601DateFormat Nothing) (T.unpack lastEnd)
+  intervals "pass" start 10 -- stop after 10 queries
+  a <- T.readFile authorsCsv
+  T.writeFile authorsCsv  (dups a)
+  p <- T.readFile packagesCsv
+  T.writeFile packagesCsv (dups p)
+ where
+  dups = T.unlines . map head . group . sort . T.lines
+  -- Go through all github repos, by chosing small time intervals
+  intervals :: String -> Day -> Int -> IO ()
+  intervals pass start i = do
+    let newDate = addDays 10 start -- assuming less than 100 repos in 10 days
+
+    -- Remember the last succesfully scanned interval 
+    -- (to update the list and continue when query timeout reached or query failed)
+    T.writeFile lastIntervalEnd (T.pack (showGregorian newDate))
+
+-- https://api.github.com/search/repositories?q=language:haskell+created:2009-01-01..2009-02-01&sort=stars&order=desc
+    let query search = search { searchRepoOptionsLanguage = Just (Language "Haskell")
+                              , searchRepoOptionsSortBy   = Just Stars
+                              , searchRepoOptionsOrder    = Just SortDescending
+                              , searchRepoOptionsCreated  = Just (start, newDate)
+                              }
+    res <- searchRepos' (Just $ BasicAuth "user" "pass") (SearchRepoMod query)
+    either (\_-> return ()) appendToCSV res
+--    putStrLn (show res) -- for debugging
+    currentDate <- fmap utctDay getCurrentTime
+    when (newDate < currentDate && i>0) (intervals pass newDate (i-1))
+
+  appendToCSV :: SearchResult Repo -> IO ()
+  appendToCSV res = do
+    V.mapM_ extractFromRepo (searchResultResults res)
+   where
+    extractFromRepo r = do
+      T.appendFile authorsCsv  (untagName (simpleOwnerLogin (repoOwner r)) `T.append` "\n")
+      T.appendFile packagesCsv (getUrl (repoHtmlUrl r) `T.append` "\n")
+

src/GitHub/Data/Definitions.hs

@@ -15,6 +15,7 @@ import Network.HTTP.Client (HttpException)
 import qualified Control.Exception as E
 import qualified Data.ByteString   as BS
 import qualified Data.Text         as T
+import qualified Network.HTTP.Types as Types
 
 import GitHub.Data.Id   (Id)
 import GitHub.Data.Name (Name)
@@ -232,7 +233,27 @@ data OrgMemberRole
     deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic)
 
 -- | Request query string
-type QueryString = [(BS.ByteString, Maybe BS.ByteString)]
+type QueryString = [(BS.ByteString, [EscapeItem])]
+
+newtype EscapeItem = Esc Types.EscapeItem deriving (Eq,Ord, Show)
+
+unwrapEsc :: [(BS.ByteString, [EscapeItem])] -> [(BS.ByteString, [Types.EscapeItem])]
+unwrapEsc qs = map t qs
+  where t (bs, items) = (bs, map unesc items)
+        unesc (Esc i) = i
+
+wrapEsc :: [(BS.ByteString, [Types.EscapeItem])] -> [(BS.ByteString, [EscapeItem])]
+wrapEsc qs = map t qs
+  where t (bs, items) = (bs, map Esc items)
+
+instance Hashable EscapeItem where
+    hashWithSalt salt (Esc (Types.QE b)) =
+        salt `hashWithSalt` (0 :: Int)
+             `hashWithSalt` b
+    hashWithSalt salt (Esc (Types.QN b)) =
+        salt `hashWithSalt` (1 :: Int)
+             `hashWithSalt` b
+
 
 -- | Count of elements
 type Count = Int

src/GitHub/Data/Options.hs

@@ -44,6 +44,14 @@ module GitHub.Data.Options (
     optionsIrrelevantAssignee,
     optionsAnyAssignee,
     optionsNoAssignee,
+    -- * Repo Search
+    SearchRepoMod(..),
+    searchRepoModToQueryString,
+    SearchRepoOptions(..),
+    SortDirection(..),
+    License(..),
+    Language(..),
+    StarsForksUpdated(..),
     -- * Data
     IssueState (..),
     MergeableState (..),
@@ -56,13 +64,16 @@ module GitHub.Data.Options (
     HasSince,
     ) where
 
+import Data.Time.Calendar      (Day, showGregorian)
 import GitHub.Data.Definitions
 import GitHub.Data.Id          (Id, untagId)
 import GitHub.Data.Milestone   (Milestone)
 import GitHub.Data.Name        (Name, untagName)
+import GitHub.Data.Repos       (Language(..))
 import GitHub.Internal.Prelude
 import Prelude ()
 
+import qualified Network.HTTP.Types as W
 import qualified Data.Text          as T
 import qualified Data.Text.Encoding as TE
 
@@ -298,7 +309,7 @@ pullRequestOptionsToQueryString (PullRequestOptions st head_ base sort dir) =
     , mk "base" <$> base'
     ]
   where
-    mk k v = (k, Just v)
+    mk k v = (k, [Esc (W.QE v)])
     state' = case st of
         Nothing          -> "all"
         Just StateOpen   -> "open"
@@ -395,7 +406,7 @@ issueOptionsToQueryString (IssueOptions filt st labels sort dir since) =
     , mk "since" <$> since'
     ]
   where
-    mk k v = (k, Just v)
+    mk k v = (k, [Esc (W.QE v)])
     filt' = case filt of
         IssueFilterAssigned   -> "assigned"
         IssueFilterCreated    -> "created"
@@ -543,7 +554,7 @@ issueRepoOptionsToQueryString IssueRepoOptions {..} =
     , mk "mentioned" <$> mentioned'
     ]
   where
-    mk k v = (k, Just v)
+    mk k v = (k, [Esc (W.QE v)])
     filt f x = case x of
         FilterAny          -> Just "*"
         FilterNone         -> Just "none"
@@ -602,3 +613,143 @@ optionsAnyAssignee = IssueRepoMod $ \opts ->
 optionsNoAssignee :: IssueRepoMod
 optionsNoAssignee = IssueRepoMod $ \opts ->
     opts { issueRepoOptionsAssignee = FilterNone }
+
+------------------------------------------------------------------------------------
+-- SearchRepo Options
+------------------------------------------------------------------------------------
+
+data StarsForksUpdated
+    = Stars
+    | Forks
+    | Updated
+  deriving
+    (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data)
+
+instance ToJSON StarsForksUpdated where
+    toJSON Stars = String "stars"
+    toJSON Forks = String "forks"
+    toJSON Updated = String "updated"
+
+instance FromJSON StarsForksUpdated where
+    parseJSON (String "stars") = pure Stars
+    parseJSON (String "forks") = pure Forks
+    parseJSON (String "updated") = pure Updated
+    parseJSON v                 = typeMismatch "StarsForksUpdated" v
+
+newtype License = License Text
+   deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+data RepoUser = Repo | User
+  deriving
+    (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data)
+
+data RepoIn = RName | RDescription | Readme
+  deriving
+    (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data)
+
+type Topic = String
+
+data SearchRepoOptions = SearchRepoOptions
+    { searchRepoOptionsKeyword  :: !Text
+    , searchRepoOptionsSortBy   :: !(Maybe StarsForksUpdated)
+    , searchRepoOptionsOrder    :: !(Maybe SortDirection)
+    , searchRepoOptionsCreated  :: !(Maybe (Day, Day)) -- period
+    , searchRepoOptionsPushed   :: !(Maybe (Day, Day))
+    , searchRepoOptionsFork     :: !(Maybe Bool)
+    , searchRepoOptionsForks    :: !(Maybe Int)
+    , searchRepoOptionsIn       :: !(Maybe RepoIn)
+    , searchRepoOptionsLanguage :: !(Maybe Language)
+    , searchRepoOptionsLicense  :: !(Maybe License)
+    , searchRepoOptionsRepoUser :: !(Maybe RepoUser)
+    , searchRepoOptionsSize     :: !(Maybe Int)
+    , searchRepoOptionsStars    :: !(Maybe Int)
+    , searchRepoOptionsTopic    :: !(Maybe Topic)
+    , searchRepoOptionsArchived :: !(Maybe Bool)
+    }
+  deriving
+    (Eq, Ord, Show, Generic, Typeable, Data)
+
+defaultSearchRepoOptions :: SearchRepoOptions
+defaultSearchRepoOptions = SearchRepoOptions
+    { searchRepoOptionsKeyword  = ""
+    , searchRepoOptionsSortBy   = Nothing
+    , searchRepoOptionsOrder    = Nothing
+    , searchRepoOptionsCreated  = Nothing
+    , searchRepoOptionsPushed   = Nothing
+    , searchRepoOptionsFork     = Nothing
+    , searchRepoOptionsForks    = Nothing
+    , searchRepoOptionsIn       = Nothing
+    , searchRepoOptionsLanguage = Nothing
+    , searchRepoOptionsLicense  = Nothing
+    , searchRepoOptionsRepoUser = Nothing
+    , searchRepoOptionsSize     = Nothing
+    , searchRepoOptionsStars    = Nothing
+    , searchRepoOptionsTopic    = Nothing
+    , searchRepoOptionsArchived = Nothing
+    }
+
+-- | See <https://developer.github.com/v3/issues/#parameters-1>.
+newtype SearchRepoMod = SearchRepoMod (SearchRepoOptions -> SearchRepoOptions)
+
+instance Semigroup SearchRepoMod where
+    SearchRepoMod f <> SearchRepoMod g = SearchRepoMod (g . f)
+
+instance Monoid SearchRepoMod where
+    mempty  = SearchRepoMod id
+    mappend = (<>)
+
+toSearchRepoOptions :: SearchRepoMod -> SearchRepoOptions
+toSearchRepoOptions (SearchRepoMod f) = f defaultSearchRepoOptions
+
+searchRepoModToQueryString :: SearchRepoMod -> QueryString
+searchRepoModToQueryString = searchRepoOptionsToQueryString . toSearchRepoOptions
+
+searchRepoOptionsToQueryString :: SearchRepoOptions -> QueryString
+searchRepoOptionsToQueryString SearchRepoOptions {..} =
+    [ ("q", plussedArgs)
+    ] ++ catMaybes
+    [ mk "sort"     <$> fmap sort' searchRepoOptionsSortBy
+    , mk "order"    <$> fmap direction' searchRepoOptionsOrder
+    , mk "fork"     <$> fmap (one . T.pack . show) searchRepoOptionsFork
+    , mk "forks"    <$> fmap (one . T.pack . show) searchRepoOptionsForks
+    , mk "size"     <$> fmap (one . T.pack . show) searchRepoOptionsSize
+    , mk "stars"    <$> fmap (one . T.pack . show) searchRepoOptionsStars
+    , mk "archived" <$> fmap (one . T.pack . show) searchRepoOptionsArchived
+    ]
+  where
+    mk k v = (k, v)
+    one = (\x -> [x]) . Esc . W.QE . TE.encodeUtf8
+
+    -- example  q=tetris+language:assembly+topic:ruby
+    -- into       [QS "tetris", QPlus, QS "language", QColon, QS "assembly", QPlus, ..
+    plussedArgs = [Esc (W.QE (TE.encodeUtf8 searchRepoOptionsKeyword)),
+                   Esc (W.QN "+")] ++ intercalate [Esc (W.QN "+")]
+       ( catMaybes [ ([Esc (W.QE "created"),  Esc (W.QN ":")] ++) <$> created'
+                   , ([Esc (W.QE "pushed"),   Esc (W.QN ":")] ++) <$> pushed'
+                   , ([Esc (W.QE "topic"),    Esc (W.QN ":")] ++) <$> topic'
+                   , ([Esc (W.QE "language"), Esc (W.QN ":")] ++) <$> language'
+                   , ([Esc (W.QE "license"),  Esc (W.QN ":")] ++) <$> license'
+                   ])
+
+    sort' x = case x of
+        Stars   -> [Esc (W.QE "stars")]
+        Forks   -> [Esc (W.QE "forks")]
+        Updated -> [Esc (W.QE "updated")]
+
+    direction' x = case x of
+        SortDescending -> [Esc (W.QE "desc")]
+        SortAscending  -> [Esc (W.QE "asc")]
+
+    created'  = one . T.pack . (\(x,y) -> showGregorian x
+                                          ++ ".." ++
+                                          showGregorian y) <$> searchRepoOptionsCreated
+
+    pushed'   = one . T.pack . (\(x,y) -> showGregorian x
+                                          ++ ".." ++
+                                          showGregorian y) <$> searchRepoOptionsPushed
+    topic' = one . T.pack <$> searchRepoOptionsTopic
+    language' = one . (\(Language x) -> x) <$> searchRepoOptionsLanguage
+
+    -- see <https://help.github.com/articles/licensing-a-repository/#searching-github-by-license-type>
+    license' = one . (\(License x) -> x) <$> searchRepoOptionsLicense
+

src/GitHub/Endpoints/GitData/Trees.hs

@@ -18,6 +18,7 @@ module GitHub.Endpoints.GitData.Trees (
 import GitHub.Data
 import GitHub.Internal.Prelude
 import GitHub.Request
+import qualified Network.HTTP.Types as Types
 import Prelude ()
 
 -- | A tree for a SHA1.
@@ -56,4 +57,5 @@ nestedTree = nestedTree' Nothing
 -- See <https://developer.github.com/v3/git/trees/#get-a-tree-recursively>
 nestedTreeR :: Name Owner -> Name Repo -> Name Tree -> Request k Tree
 nestedTreeR user repo sha =
-    query  ["repos", toPathPart user, toPathPart repo, "git", "trees", toPathPart sha] [("recursive", Just "1")]
+    query  ["repos", toPathPart user, toPathPart repo, "git", "trees", toPathPart sha]
+           [("recursive", [Esc (Types.QE "1")])]

src/GitHub/Endpoints/Organizations/Members.hs

@@ -20,6 +20,7 @@ module GitHub.Endpoints.Organizations.Members (
 import GitHub.Data
 import GitHub.Internal.Prelude
 import GitHub.Request
+import qualified Network.HTTP.Types as W
 import Prelude ()
 
 -- | All the users who are members of the specified organization,
@@ -49,7 +50,8 @@ membersOfR organization =
 -- See <https://developer.github.com/v3/orgs/members/#members-list>
 membersOfWithR :: Name Organization -> OrgMemberFilter -> OrgMemberRole -> FetchCount -> Request k (Vector SimpleUser)
 membersOfWithR org f r =
-    pagedQuery ["orgs", toPathPart org, "members"] [("filter", Just f'), ("role", Just r')]
+    pagedQuery ["orgs", toPathPart org, "members"]
+               [("filter", [Esc (W.QE f')]), ("role", [Esc (W.QE r')])]
   where
     f' = case f of
         OrgMemberFilter2faDisabled -> "2fa_disabled"

src/GitHub/Endpoints/Organizations/Teams.hs

@@ -41,6 +41,8 @@ import GitHub.Internal.Prelude
 import GitHub.Request
 import Prelude ()
 
+import qualified Network.HTTP.Types as W
+
 -- | List teams.  List the teams of an Owner.
 -- When authenticated, lists private teams visible to the authenticated user.
 -- When unauthenticated, lists only public teams for an Owner.
@@ -133,7 +135,7 @@ deleteTeamR tid =
 -- See <https://developer.github.com/v3/orgs/teams/#list-team-members>
 listTeamMembersR :: Id Team -> TeamMemberRole -> FetchCount -> Request 'RA (Vector SimpleUser)
 listTeamMembersR tid r =
-    pagedQuery ["teams", toPathPart tid, "members"] [("role", Just r')]
+    pagedQuery ["teams", toPathPart tid, "members"] [("role", [Esc (W.QE r')])]
   where
     r' = case r of
         TeamMemberRoleAll         -> "all"