Rename GitHub module to Http

Author: evancz

src/backend/GitHub.hs renamed to src/backend/Http.hs

@@ -1,6 +1,6 @@
 {-# OPTIONS_GHC -Wall #-}
 {-# LANGUAGE OverloadedStrings #-}
-module GitHub (Token, init, fetch) where
+module Http (Token, init, fetch, fetchGithub) where
 
 
 import Prelude hiding (init)
@@ -31,7 +31,7 @@ init :: String -> IO Token
 init githubToken =
   do  manager <- Http.newManager Http.tlsManagerSettings
       let token = Token manager githubToken
-      response <- fetch token "/"
+      response <- fetchGithub token "/"
       case response of
         Left err ->
           error $ "Bad OAuth access token for GitHub.\n" ++ err
@@ -41,15 +41,32 @@ init githubToken =
 
 
 
--- GITHUB REQUESTS
+-- ARBITRARY REQUESTS
 
 
 fetch :: Token -> String -> IO (Either String LBS.ByteString)
-fetch (Token manager token) path =
+fetch (Token manager _) url =
   let
-    recover e =
-      return $ Left $ show (e :: SomeException)
+    attempt =
+      do  request <- Http.parseUrlThrow url
+          response <- Http.httpLbs request manager
+          return $ Right $ Http.responseBody response
+  in
+    attempt `catch` recover
+
+
+recover :: SomeException -> IO (Either String a)
+recover e =
+  return $ Left $ show e
 
+
+
+-- GITHUB REQUESTS
+
+
+fetchGithub :: Token -> String -> IO (Either String LBS.ByteString)
+fetchGithub (Token manager token) path =
+  let
     attempt =
       do  request <- Http.parseUrlThrow $ "https://api.github.com" ++ path
           response <- flip Http.httpLbs manager $ request

src/backend/Main.hs

@@ -8,7 +8,7 @@ import System.Console.CmdArgs
 import System.Directory (doesFileExist, createDirectoryIfMissing)
 
 import qualified Artifacts
-import qualified GitHub
+import qualified Http
 import qualified Memory
 import qualified Server
 
@@ -54,7 +54,7 @@ main =
         else Artifacts.compile
 
       memory <- Memory.init
-      token <- GitHub.init (github cargs)
+      token <- Http.init (github cargs)
 
       let config = setPort (port cargs) defaultConfig
       httpServe config (Server.serve token memory)

src/backend/Package/Register.hs

@@ -21,7 +21,7 @@ import qualified System.IO as IO
 import qualified System.IO.Streams as Stream
 
 import qualified Elm.Package as Pkg
-import qualified GitHub
+import qualified Http
 import qualified Json.Decode as Decode
 import qualified Json.Encode as Encode
 import qualified Memory
@@ -40,7 +40,7 @@ import qualified Server.Error as Error
 
 -}
 
-register :: GitHub.Token -> Memory.Memory -> Snap.Snap ()
+register :: Http.Token -> Memory.Memory -> Snap.Snap ()
 register token memory =
   do  name <- verifyName =<< getQueryParam "name"
       commitHash <- getQueryParam "commit-hash"
@@ -103,7 +103,7 @@ badNameMessage name problem =
 -- VERIFY VERSION
 
 
-verifyVersion :: GitHub.Token -> Memory.Memory -> Pkg.Name -> Text -> Text -> Snap.Snap Pkg.Version
+verifyVersion :: Http.Token -> Memory.Memory -> Pkg.Name -> Text -> Text -> Snap.Snap Pkg.Version
 verifyVersion token memory name commitHash rawVersion =
   case Pkg.versionFromText rawVersion of
     Left problem ->
@@ -128,16 +128,16 @@ verifyIsNew memory name vsn =
             "Version " ++ Pkg.versionToString vsn ++ " has already been published."
 
 
-verifyTag :: GitHub.Token -> Pkg.Name -> Pkg.Version -> Text -> Snap.Snap ()
+verifyTag :: Http.Token -> Pkg.Name -> Pkg.Version -> Text -> Snap.Snap ()
 verifyTag token name version commitHash =
   do  githubHash <- getCommitHash token name version
       when (commitHash /= githubHash) $ Error.string 400 $
         "The commit tagged on github as " ++ Pkg.versionToString version ++ " is not the one I was expecting."
 
 
-getCommitHash :: GitHub.Token -> Pkg.Name -> Pkg.Version -> Snap.Snap Text
+getCommitHash :: Http.Token -> Pkg.Name -> Pkg.Version -> Snap.Snap Text
 getCommitHash token name version =
-  do  response <- liftIO $ GitHub.fetch token $
+  do  response <- liftIO $ Http.fetchGithub token $
         "/repos/" ++ Pkg.toUrl name ++ "/git/refs/tags/" ++ Pkg.versionToString version
 
       case response of

src/backend/Server.hs

@@ -13,7 +13,7 @@ import qualified Elm.Compiler.Module as Module
 import qualified Elm.Package as Pkg
 import qualified Json.Encode as Encode
 
-import qualified GitHub
+import qualified Http
 import Memory (Memory)
 import qualified Memory
 import qualified Memory.History as History
@@ -28,7 +28,7 @@ import qualified ServeFile
 -- SERVE
 
 
-serve :: GitHub.Token -> Memory -> S.Snap ()
+serve :: Http.Token -> Memory -> S.Snap ()
 serve token memory =
   asum
     [