{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Niv.GitHub where
import Control.Arrow
import Data.Bool
import Data.Maybe
import qualified Data.Text as T
import Niv.GitHub.API
import Niv.Update
githubUpdate ::
(Bool -> T.Text -> IO T.Text) ->
(T.Text -> T.Text -> T.Text -> IO T.Text) ->
(T.Text -> T.Text -> IO GithubRepo) ->
Update () ()
githubUpdate :: (Bool -> Text -> IO Text)
-> (Text -> Text -> Text -> IO Text)
-> (Text -> Text -> IO GithubRepo)
-> Update () ()
githubUpdate Bool -> Text -> IO Text
prefetch Text -> Text -> Text -> IO Text
latestRev Text -> Text -> IO GithubRepo
ghRepo = proc () -> do
Box Text
urlTemplate <-
Update (Box Text) (Box Text)
template
Update (Box Text) (Box Text)
-> Update () (Box Text) -> Update () (Box Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< (Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"url_template" Update (Box Text) (Box Text)
-> Update () (Box Text) -> Update () (Box Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< Update () (Box Text)
completeSpec) Update () (Box Text)
-> Update () (Box Text) -> Update () (Box Text)
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> (Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"url_template")
-<
()
Box Text
url <- Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"url" -< Box Text
urlTemplate
let isTarGuess :: Box Bool
isTarGuess = (\Text
u -> Text
"tar.gz" Text -> Text -> Bool
`T.isSuffixOf` Text
u Bool -> Bool -> Bool
|| Text
".tgz" Text -> Text -> Bool
`T.isSuffixOf` Text
u) (Text -> Bool) -> Box Text -> Box Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Text
url
Box Text
type' <- Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"type" -< Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool Text
"file" Text
"tarball" (Bool -> Text) -> Box Bool -> Box Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Bool
isTarGuess :: Box T.Text
let doUnpack :: Box Bool
doUnpack = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"tarball") (Text -> Bool) -> Box Text -> Box Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Text
type'
Box Text
_sha256 <- Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"sha256" Update (Box Text) (Box Text)
-> Update (Box (Bool, Text)) (Box Text)
-> Update (Box (Bool, Text)) (Box Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< ((Bool, Text) -> IO Text) -> Update (Box (Bool, Text)) (Box Text)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (\(Bool
up, Text
u) -> Bool -> Text -> IO Text
prefetch Bool
up Text
u) -< (,) (Bool -> Text -> (Bool, Text))
-> Box Bool -> Box (Text -> (Bool, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Bool
doUnpack Box (Text -> (Bool, Text)) -> Box Text -> Box (Bool, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box Text
url
Update () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()
where
completeSpec :: Update () (Box T.Text)
completeSpec :: Update () (Box Text)
completeSpec = proc () -> do
Box Text
owner <- Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"owner" -< ()
Box Text
repo <- Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"repo" -< ()
Box GithubRepo
repoInfo <- ((Text, Text) -> IO GithubRepo)
-> Update (Box (Text, Text)) (Box GithubRepo)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run (\(Text
a, Text
b) -> Text -> Text -> IO GithubRepo
ghRepo Text
a Text
b) -< (,) (Text -> Text -> (Text, Text))
-> Box Text -> Box (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Text
owner Box (Text -> (Text, Text)) -> Box Text -> Box (Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box Text
repo
Box Text
branch <-
Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"branch" Update (Box Text) (Box Text)
-> Update (Box (Maybe Text)) (Box Text)
-> Update (Box (Maybe Text)) (Box Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< (Box (Maybe Text) -> Box Text)
-> Update (Box (Maybe Text)) (Box Text)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Maybe Text -> Text) -> Box (Maybe Text) -> Box Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe Text -> Text) -> Box (Maybe Text) -> Box Text)
-> (Maybe Text -> Text) -> Box (Maybe Text) -> Box Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"master")
-<
GithubRepo -> Maybe Text
repoDefaultBranch (GithubRepo -> Maybe Text) -> Box GithubRepo -> Box (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box GithubRepo
repoInfo
Box (Maybe Text)
_description <- Text -> Update (Box (Maybe Text)) (Box (Maybe Text))
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"description" -< GithubRepo -> Maybe Text
repoDescription (GithubRepo -> Maybe Text) -> Box GithubRepo -> Box (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box GithubRepo
repoInfo
Box (Maybe Text)
_homepage <- Text -> Update (Box (Maybe Text)) (Box (Maybe Text))
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"homepage" -< GithubRepo -> Maybe Text
repoHomepage (GithubRepo -> Maybe Text) -> Box GithubRepo -> Box (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box GithubRepo
repoInfo
Box Text
_ <-
Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"rev" Update (Box Text) (Box Text)
-> Update (Box (Text, Text, Text)) (Box Text)
-> Update (Box (Text, Text, Text)) (Box Text)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< ((Text, Text, Text) -> IO Text)
-> Update (Box (Text, Text, Text)) (Box Text)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run' (\(Text
a, Text
b, Text
c) -> Text -> Text -> Text -> IO Text
latestRev Text
a Text
b Text
c)
-<
(,,) (Text -> Text -> Text -> (Text, Text, Text))
-> Box Text -> Box (Text -> Text -> (Text, Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Text
owner Box (Text -> Text -> (Text, Text, Text))
-> Box Text -> Box (Text -> (Text, Text, Text))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box Text
repo Box (Text -> (Text, Text, Text))
-> Box Text -> Box (Text, Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box Text
branch
Update (Box Text) (Box Text)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Text -> Box Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
githubURLTemplate
githubURLTemplate :: T.Text
githubURLTemplate :: Text
githubURLTemplate =
(if Bool
githubSecure then Text
"https://" else Text
"http://")
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
githubHost
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
githubPath
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"<owner>/<repo>/archive/<rev>.tar.gz"