@@ -0,0 +1,83 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE TypeOperators #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+import Control.Applicative
6+import Control.Monad
7+import Control.Monad.IO.Class
8+import Control.Monad.Trans.Either
9+import Data.Aeson
10+import Data.Monoid
11+import Data.Proxy
12+import Data.Text (Text)
13+import GHC.Generics
14+import Servant.API
15+import Servant.Client
16+
17+import qualified Data.Text as T
18+import qualified Data.Text.IO as T
19+
20+type HackageAPI =
21+ "users" :> Get '[JSON] [UserSummary]
22+ :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed
23+ :<|> "packages" :> Get '[JSON] [Package]
24+
25+type Username = Text
26+
27+data UserSummary = UserSummary
28+ { summaryUsername :: Username
29+ , summaryUserid :: Int
30+ } deriving (Eq, Show)
31+
32+instance FromJSON UserSummary where
33+ parseJSON (Object o) =
34+ UserSummary <$> o .: "username"
35+ <*> o .: "userid"
36+
37+ parseJSON _ = mzero
38+
39+type Group = Text
40+
41+data UserDetailed = UserDetailed
42+ { username :: Username
43+ , userid :: Int
44+ , groups :: [Group]
45+ } deriving (Eq, Show, Generic)
46+
47+instance FromJSON UserDetailed
48+
49+newtype Package = Package { packageName :: Text }
50+ deriving (Eq, Show, Generic)
51+
52+instance FromJSON Package
53+
54+hackageAPI :: Proxy HackageAPI
55+hackageAPI = Proxy
56+
57+getUsers :: BaseUrl -> EitherT ServantError IO [UserSummary]
58+getUser :: Username -> BaseUrl -> EitherT ServantError IO UserDetailed
59+getPackages :: BaseUrl -> EitherT ServantError IO [Package]
60+getUsers :<|> getUser :<|> getPackages = client hackageAPI
61+
62+run :: (BaseUrl -> r) -> r
63+run f = f (BaseUrl Http "hackage.haskell.org" 80)
64+
65+main :: IO ()
66+main = print =<< uselessNumbers
67+
68+uselessNumbers :: IO (Either ServantError ())
69+uselessNumbers = runEitherT $ do
70+ users <- run getUsers
71+ liftIO . putStrLn $ show (length users) ++ " users"
72+
73+ user <- liftIO $ do
74+ putStrLn "Enter a valid hackage username"
75+ T.getLine
76+ userDetailed <- run (getUser user)
77+ liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages"
78+
79+ packages <- run getPackages
80+ let monadPackages = filter (isMonadPackage . packageName) packages
81+ liftIO . putStrLn $ show (length monadPackages) ++ " monad packages"
82+
83+ where isMonadPackage = T.isInfixOf "monad"