Implement remote file check as Haskell command

1 files changed, 29 insertions, 0 deletions

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