diff --git a/NationStates.hs b/NationStates.hs --- a/NationStates.hs +++ b/NationStates.hs @@ -23,7 +23,7 @@ :: String -- ^ User agent -> IO Context -newContext userAgent = newContext' userAgent False +newContext userAgent = newContext' userAgent True -- | Create a new 'Context', with extra options. @@ -31,7 +31,7 @@ :: String -- ^ User agent -> Bool - -- ^ Use HTTPS (experimental) + -- ^ Use HTTPS -> IO Context newContext' userAgent isSecure = do man <- newManager $ diff --git a/NationStates/Core.hs b/NationStates/Core.hs --- a/NationStates/Core.hs +++ b/NationStates/Core.hs @@ -17,6 +17,10 @@ -- * Query strings Query(..), + shard, + shard', + withOptions, + withParams, -- * Connection manager Context(..), @@ -34,6 +38,7 @@ import Control.Applicative +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BC import Data.Functor.Compose import qualified Data.Foldable as F @@ -87,28 +92,20 @@ -> String -- ^ XML element name -> NS String -makeNS shard elemName = makeNS' shard Nothing [] parse +makeNS shardName elemName = makeNS' (shard shardName) parse where parse _ = strContent . fromMaybe errorMissing . findChild (unqual elemName) errorMissing = error $ "missing <" ++ elemName ++ "> element" --- | Construct a request for a single shard. +-- | Construct a request. makeNS' - :: String - -- ^ Shard name - -> Maybe Integer - -- ^ Shard ID - -> [(String, String)] - -- ^ List of options + :: Query + -- ^ Query string -> (Query -> Element -> a) -- ^ Function for parsing the response -> NS a -makeNS' name maybeId options parse = Compose - (Query { - queryShards = Map.singleton name (Set.singleton maybeId), - queryOptions = Map.fromList options - }, Compose parse) +makeNS' query parse = Compose (query, Compose parse) -- | Perform a request on the NationStates API. @@ -126,16 +123,13 @@ where parse = p q . fromMaybe (error "invalid response") . parseXMLDoc req = initRequest { - queryString - = HTTP.renderQuery True (HTTP.toQuery $ - F.toList kindAndName ++ [("q", shards), ("v", show apiVersion)]) - <> BC.pack options, + queryString = queryToString kindAndName q, requestHeaders = ("User-Agent", BC.pack $ contextUserAgent c) : requestHeaders initRequest, + port = if contextIsSecure c then 443 else 80, secure = contextIsSecure c } - (shards, options) = queryToUrl q initRequest :: Request Just initRequest = parseUrl "http://www.nationstates.net/cgi-bin/api.cgi" @@ -169,28 +163,61 @@ -- | Keeps track of the set of shards to request. data Query = Query { queryShards :: Map String (Set (Maybe Integer)), - queryOptions :: Map String String + queryOptions :: Map String String, + queryParams :: Map String String } deriving Show instance Monoid Query where - mempty = Query mempty mempty + mempty = Query mempty mempty mempty mappend a b = Query { queryShards = Map.unionWith Set.union (queryShards a) (queryShards b), queryOptions = Map.unionWithKey mergeOptions - (queryOptions a) (queryOptions b) + (queryOptions a) (queryOptions b), + queryParams = Map.unionWithKey mergeOptions + (queryParams a) (queryParams b) } where mergeOptions key _ _ = error $ "conflicting values for option " ++ show key -queryToUrl :: Query -> (String, String) -queryToUrl q = (shards, options) +-- | Create a query for a single shard. +shard :: String -> Query +shard name = mempty { + queryShards = Map.singleton name (Set.singleton Nothing) } + +-- | Create a query for a single shard, with an extra ID. +-- +-- For example, the @censusscore-23@ shard would be written as: +-- @shard' "censusscore" 23@. +shard' :: String -> Integer -> Query +shard' name id' = mempty { + queryShards = Map.singleton name (Set.singleton (Just id')) } + +-- | Add extra @;@-delimited arguments. +withOptions :: [(String, String)] -> Query +withOptions options = mempty { queryOptions = Map.fromList options } + +-- | Add extra @&@-delimited arguments. +withParams :: [(String, String)] -> Query +withParams params = mempty { queryParams = Map.fromList params } + + +queryToString :: Maybe (String, String) -> Query -> ByteString +queryToString kindAndName q + = HTTP.renderQuery True (HTTP.toQuery $ + F.toList kindAndName + ++ Map.toList (queryParams q) + ++ [("q", shards), ("v", show apiVersion)]) + <> BC.pack options where - shards = intercalate "+" [ name ++ F.foldMap (\i -> "-" ++ show i) maybeId | - (name, is) <- Map.toList $ queryShards q, - maybeId <- Set.toList is ] + shards + | Map.null (queryShards q) = "null" + | otherwise + = intercalate "+" [ name ++ F.foldMap (\i -> "-" ++ show i) maybeId | + (name, is) <- Map.toList $ queryShards q, + maybeId <- Set.toList is ] options = concat [ ";" ++ k ++ "=" ++ v | (k, v) <- Map.toList $ queryOptions q ] diff --git a/NationStates/Nation.hs b/NationStates/Nation.hs --- a/NationStates/Nation.hs +++ b/NationStates/Nation.hs @@ -168,22 +168,22 @@ -- | General assembly vote. -- -- > Just True -gavote :: Nation WAVote -gavote = Nation . fmap (expect "General Assembly vote" <*> readWAVote) $ +gavote :: Nation (Maybe WAVote) +gavote = Nation . fmap (expect "General Assembly vote" <*> readWAVote') $ makeNS "gavote" "GAVOTE" -- | Security council vote. -- -- > Nothing -scvote :: Nation WAVote -scvote = Nation . fmap (expect "Security Council vote" <*> readWAVote) $ +scvote :: Nation (Maybe WAVote) +scvote = Nation . fmap (expect "Security Council vote" <*> readWAVote') $ makeNS "scvote" "SCVOTE" -- | Description of civil rights, economy, and political freedoms. -- -- > ("Excellent","Strong","Very Good") freedom :: Nation (String, String, String) -freedom = Nation $ makeNS' "freedom" Nothing [] parse +freedom = Nation $ makeNS' (shard "freedom") parse where parse _ root | Just parent <- findChild (unqual "FREEDOM") root @@ -246,7 +246,7 @@ -- -- > ["v1","o4","b14","t23","m3"] banners :: Nation [String] -banners = Nation $ makeNS' "banners" Nothing [] parse +banners = Nation $ makeNS' (shard "banners") parse where parse _ root | Just parent <- findChild (unqual "BANNERS") root @@ -260,7 +260,7 @@ -- -- > (24,6.0) censusscore :: Nation (Integer, Double) -censusscore = Nation $ makeNS' "censusscore" Nothing [] parse +censusscore = Nation $ makeNS' (shard "censusscore") parse where parse q root | Just (i, _) <- MultiSet.minView $ MultiSet.difference response request @@ -278,7 +278,7 @@ -- -- > 94.0 censusscore' :: Integer -> Nation Double -censusscore' i = Nation $ makeNS' "censusscore" (Just i) [] parse +censusscore' i = Nation $ makeNS' (shard' "censusscore" i) parse where parse _ = fromMaybe (error $ "could not find census " ++ show i) . lookup i . extractCensusScores diff --git a/NationStates/Region.hs b/NationStates/Region.hs --- a/NationStates/Region.hs +++ b/NationStates/Region.hs @@ -124,9 +124,11 @@ -- | The number of votes for and against the current General Assembly -- resolution. -- --- > (28,11) -gavote :: Region (Integer, Integer) -gavote = Region $ makeNS' "gavote" Nothing [] parse +-- Returns @Nothing@ when there is no proposal at vote. +-- +-- > Just (28,11) +gavote :: Region (Maybe (Integer, Integer)) +gavote = Region $ makeNS' (shard "gavote") parse where parse _ = expect "GA vote counts" <$> showElement <*> (grabVotes <=< findChild (unqual "GAVOTE")) @@ -134,17 +136,22 @@ -- | The number of votes for and against the current Security Council -- resolution. -- --- > (20,34) -scvote :: Region (Integer, Integer) -scvote = Region $ makeNS' "scvote" Nothing [] parse +-- Returns @Nothing@ when there is no proposal at vote. +-- +-- > Just (20,34) +scvote :: Region (Maybe (Integer, Integer)) +scvote = Region $ makeNS' (shard "scvote") parse where parse _ = expect "SC vote counts" <$> showElement <*> (grabVotes <=< findChild (unqual "SCVOTE")) -grabVotes :: Element -> Maybe (Integer, Integer) -grabVotes root = (,) - <$> (readMaybe . strContent =<< findChild (unqual "FOR") root) - <*> (readMaybe . strContent =<< findChild (unqual "AGAINST") root) +grabVotes :: Element -> Maybe (Maybe (Integer, Integer)) +grabVotes root = do + forStr <- grab "FOR" + againstStr <- grab "AGAINST" + return $ (,) <$> readMaybe forStr <*> readMaybe againstStr + where + grab childName = strContent <$> findChild (unqual childName) root -- | Region founder. -- @@ -170,7 +177,7 @@ -- -- > ["New Lunar Republic","Tareldanore"] embassies :: Region [String] -embassies = Region $ makeNS' "embassies" Nothing [] parse +embassies = Region $ makeNS' (shard "embassies") parse where parse _ = expect "embassy names" <$> showElement <*> fmap (grabChildren "EMBASSY") . findChild (unqual "EMBASSIES") @@ -179,7 +186,7 @@ -- -- > ["Silly","Monarchist","Large"] tags :: Region [String] -tags = Region $ makeNS' "tags" Nothing [] parse +tags = Region $ makeNS' (shard "tags") parse where parse _ = expect "region tags" <$> showElement <*> fmap (grabChildren "TAG") . findChild (unqual "TAGS") diff --git a/NationStates/Types.hs b/NationStates/Types.hs --- a/NationStates/Types.hs +++ b/NationStates/Types.hs @@ -3,6 +3,10 @@ module NationStates.Types where +import Control.Applicative +import Prelude -- GHC 7.10 + + -- | Nation category. -- -- This datum summarizes a nation's personal, economic, and political @@ -122,6 +126,11 @@ "FOR" -> Just $ Just True "AGAINST" -> Just $ Just False _ -> Nothing + +readWAVote' :: String -> Maybe (Maybe WAVote) +readWAVote' s + | null s = Just Nothing + | otherwise = Just <$> readWAVote s showWAVote :: WAVote -> String showWAVote v = case v of diff --git a/NationStates/Verify.hs b/NationStates/Verify.hs new file mode 100644 --- /dev/null +++ b/NationStates/Verify.hs @@ -0,0 +1,51 @@ +-- | The Authentication API. +-- +-- See . +-- +-- Here's a short example: +-- +-- @ +-- import NationStates +-- import qualified NationStates.Nation as Nation +-- import qualified NationStates.Verify as Nation +-- +-- main = do +-- c <- 'NationStates.newContext' "ExampleBot/2000" +-- ok <- Nation.run "The Vines" (Nation.verify checksum token) c +-- putStrLn $ if ok then \"Success\" else \"Failure\" +-- where +-- checksum = \"CCT60sf2CfylDqSNzCMleqsvxrwjiG-9Zw4TXZjdMmk\" +-- token = Just "testing123" +-- @ + +module NationStates.Verify ( + verify, + ) where + + +import qualified Data.Foldable as F +import Text.XML.Light + +import NationStates.Core +import NationStates.Nation (Nation(..)) + + +-- | Add an authentication token to an existing 'Nation' request. +verify + :: String + -- ^ Checksum + -> Maybe String + -- ^ Site-specific token + -> Nation Bool +verify checksum token = Nation $ makeNS' query parse + where + query = withParams $ + [("a", "verify"), ("checksum", checksum)] + ++ F.foldMap (\t -> [("token", t)]) token + parse _ root + | Just e <- findChild (unqual "VERIFY") root = + case strContent e of + "0" -> False + "1" -> True + s -> error $ "invalid value for : " ++ show s + | otherwise = error "missing element" diff --git a/nationstates.cabal b/nationstates.cabal --- a/nationstates.cabal +++ b/nationstates.cabal @@ -1,5 +1,5 @@ name: nationstates -version: 0.4.0.0 +version: 0.5.0.0 synopsis: NationStates API client description: NationStates API client @@ -24,6 +24,7 @@ NationStates.Nation NationStates.Region NationStates.Types + NationStates.Verify build-depends: base >= 4.6 && < 5, bytestring, @@ -33,6 +34,7 @@ http-client-tls, http-types, multiset, + tls >= 1.3.3, transformers, xml default-language: Haskell2010