Implement remote file check as Haskell command

4 files changed, 39 insertions, 1 deletions

diff --git a/app/SlackBuilder/CommandLine.hs b/app/SlackBuilder/CommandLine.hs
index 6b915f2..4218e6b 100644
--- a/app/SlackBuilder/CommandLine.hs
+++ b/app/SlackBuilder/CommandLine.hs
@@ -25,6 +25,7 @@ data SlackBuilderCommand
     | GhCommand GhArguments
     | SlackBuildCommand Text Text
     | CommitCommand Text Text
+    | ExistsCommand Text
     deriving (Eq, Show)
 
 data PackagistArguments = PackagistArguments
@@ -65,6 +66,7 @@ slackBuilderCommand = subparser
     <> command "github" (info (GhCommand <$> ghArguments) mempty)
     <> command "slackbuild" (info slackBuildCommand mempty)
     <> command "commit" (info commitCommand mempty)
+    <> command "exists" (info existsCommand mempty)
   where
     slackBuildCommand = SlackBuildCommand
         <$> argument str (metavar "PATH")
@@ -72,3 +74,4 @@ slackBuilderCommand = subparser
     commitCommand = CommitCommand
         <$> argument str (metavar "PATH")
         <*> argument str (metavar "VERSION")
+    existsCommand = ExistsCommand <$> argument str (metavar "PATH")
diff --git a/app/SlackBuilder/Config.hs b/app/SlackBuilder/Config.hs
index 6e093a7..5168666 100644
--- a/app/SlackBuilder/Config.hs
+++ b/app/SlackBuilder/Config.hs
@@ -11,6 +11,7 @@ data Settings = Settings
     { ghToken :: !Text
     , repository :: !FilePath
     , branch :: Text
+    , downloadURL :: Text
     } deriving (Eq, Show)
 
 settingsCodec :: Toml.TomlCodec Settings
@@ -18,3 +19,4 @@ settingsCodec = Settings
     <$> Toml.text "gh_token" .= ghToken
     <*> Toml.string "repository" .= repository
     <*> Toml.text "branch" .= branch
+    <*> Toml.text "download_url" .= downloadURL
diff --git a/app/SlackBuilder/Download.hs b/app/SlackBuilder/Download.hs
index 2b4f5dd..83db687 100644
--- a/app/SlackBuilder/Download.hs
+++ b/app/SlackBuilder/Download.hs
@@ -1,5 +1,7 @@
 module SlackBuilder.Download
     ( commit
+    , hostedSources
+    , remoteFileExists
     , updateSlackBuildVersion
     ) where
 
@@ -15,6 +17,19 @@ import System.FilePath ((</>), (<.>))
 import System.Process (CreateProcess(..), StdStream(..), proc, readCreateProcessWithExitCode, callProcess)
 import System.Exit (ExitCode(..))
 import Control.Monad (unless)
+import Text.URI (URI(..), mkURI)
+import Network.HTTP.Req
+    ( useHttpsURI
+    , HEAD(..)
+    , NoReqBody(..)
+    , req
+    , runReq
+    , defaultHttpConfig
+    , ignoreResponse
+    , responseStatusCode, HttpConfig (..)
+    )
+import Data.Maybe (fromMaybe)
+import Data.Functor ((<&>))
 
 updateSlackBuildVersion :: Text -> Text -> SlackBuilderT ()
 updateSlackBuildVersion packagePath version = do
@@ -54,3 +69,17 @@ commit packagePath version = do
                 , std_err = UseHandle nullHandle
                 }
          in readCreateProcessWithExitCode createCheckoutProcess ""
+
+hostedSources :: Text -> SlackBuilderT URI
+hostedSources absoluteURL = SlackBuilderT (asks downloadURL)
+    >>= liftIO . mkURI . (<> absoluteURL)
+
+remoteFileExists :: Text -> SlackBuilderT Bool
+remoteFileExists url = hostedSources url
+    >>= traverse (runReq httpConfig . go . fst) . useHttpsURI
+    <&> maybe False ((== 200) . responseStatusCode)
+  where
+    httpConfig = defaultHttpConfig
+        { httpConfigCheckResponse = const $ const $ const Nothing
+        }
+    go uri = req HEAD uri NoReqBody ignoreResponse mempty
diff --git a/app/SlackBuilder/Updater.hs b/app/SlackBuilder/Updater.hs
index ec96018..7965a5c 100644
--- a/app/SlackBuilder/Updater.hs
+++ b/app/SlackBuilder/Updater.hs
@@ -25,7 +25,11 @@ import Network.HTTP.Req
     , jsonResponse
     , NoReqBody(..)
     , (/:)
-    , responseBody, useHttpsURI, bsResponse, POST (POST), ReqBodyJson (ReqBodyJson)
+    , responseBody
+    , useHttpsURI
+    , bsResponse
+    , POST(..)
+    , ReqBodyJson(..)
     )
 import Text.URI (mkURI)
 import SlackBuilder.CommandLine