module Jenkins.REST.Method
(
Method, Type(..), Format, As
, text, int, (-?-), (-/-), (-=-), (-&-), query
, as, JSONy(..), XMLy(..), Pythony(..)
, job, build, view, queue
, render, slash
) where
import Data.ByteString (ByteString)
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706)
import Data.ByteString.Char8 ()
#endif
import qualified Data.ByteString as B
import Data.Data (Data, Typeable)
import Data.Monoid (Monoid(..), (<>))
import Data.String (IsString(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text (Text)
import GHC.Generics (Generic)
import Network.URI (escapeURIChar, isUnreserved)
infix 1 :~?, -?-
infix 3 :~@, `as`
infix 7 :~=, -=-
infixr 5 :~/, -/-, :~&, -&-
data Method :: Type -> Format -> * where
Empty :: Method t f
Text :: Text -> Method Complete f
(:~/) :: Method Complete f -> Method Complete f -> Method Complete f
(:~@) :: Method Complete f -> As f -> Method Complete f
(:~=) :: Text -> Maybe Text -> Method Query f
(:~&) :: Method Query f -> Method Query f -> Method Query f
(:~?) :: Method Complete f -> Method Query f -> Method Complete f
deriving instance Show (As f) => Show (Method t f)
instance Num (Method Complete f) where
(+) = error "Method.(+): not supposed to be used"
(*) = error "Method.(*): not supposed to be used"
abs = error "Method.abs: not supposed to be used"
signum = error "Method.signum: not supposed to be used"
fromInteger = fromString . show
instance IsString (Method Complete f) where
fromString = Text . T.pack
instance IsString (Method Query f) where
fromString str = T.pack str :~= Nothing
data Type = Query | Complete
deriving (Show, Eq, Typeable, Data, Generic)
data Format = JSON | XML | Python
deriving (Show, Eq, Typeable, Data, Generic)
data As :: Format -> * where
AsJSON :: As JSON
AsXML :: As XML
AsPython :: As Python
deriving instance Show (As f)
deriving instance Eq (As f)
text :: Text -> Method Complete f
text = Text
int :: Integer -> Method Complete f
int = fromInteger
(-/-) :: Method Complete f -> Method Complete f -> Method Complete f
(-/-) = (:~/)
(-&-) :: Method Query f -> Method Query f -> Method Query f
(-&-) = (:~&)
(-=-) :: Text -> Text -> Method Query f
x -=- y = x :~= Just y
as :: Method Complete f -> As f -> Method Complete f
as = (:~@)
class JSONy t where
json :: t JSON
instance JSONy As where
json = AsJSON
instance t ~ Complete => JSONy (Method t) where
json = "" `as` json
class XMLy t where
xml :: t XML
instance XMLy As where
xml = AsXML
instance t ~ Complete => XMLy (Method t) where
xml = "" `as` xml
class Pythony t where
python :: t Python
instance Pythony As where
python = AsPython
instance t ~ Complete => Pythony (Method t) where
python = "" `as` python
(-?-) :: Method Complete f -> Method Query f -> Method Complete f
(-?-) = (:~?)
query :: [(Text, Maybe Text)] -> Method Query f
query [] = Empty
query xs = foldr1 (:~&) (map (uncurry (:~=)) xs)
render :: Method t f -> ByteString
render Empty = ""
render (Text s) = renderText s
render (x :~/ y) = render x `slash` render y
render (x :~@ f) =
let prefix = render x
postfix = renderFormat f
in if B.null prefix then "api" `slash` postfix else prefix `slash` "api" `slash` postfix
render (x :~= Just y) = renderText x `equals` renderText y
render (x :~= Nothing) = renderText x
render (x :~& y) = render x `ampersand` render y
render (x :~? y) = render x `question` render y
renderFormat :: IsString s => As f -> s
renderFormat AsJSON = "json"
renderFormat AsXML = "xml"
renderFormat AsPython = "python"
renderText :: Text -> ByteString
renderText = T.encodeUtf8 . T.concatMap (T.pack . escapeURIChar isUnreserved)
slash :: (IsString m, Monoid m) => m -> m -> m
slash = insert "/"
equals :: (IsString m, Monoid m) => m -> m -> m
equals = insert "="
ampersand :: (IsString m, Monoid m) => m -> m -> m
ampersand = insert "&"
question :: (IsString m, Monoid m) => m -> m -> m
question = insert "?"
insert :: (IsString m, Monoid m) => m -> m -> m -> m
insert t x y = x <> t <> y
job :: Text -> Method Complete f
job name = "job" -/- text name
build :: Integral a => Text -> a -> Method Complete f
build name num = "job" -/- text name -/- int (toInteger num)
view :: Text -> Method Complete f
view name = "view" -/- text name
queue :: Method Complete f
queue = "queue"