First commit

.gitignore

@@ -0,0 +1,9 @@
+dist
+.cabal-sandbox/
+cabal.sandbox.config
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+.virthualenv

NationStates.hs

@@ -0,0 +1,26 @@
+module NationStates (
+
+    -- * Tracking connections
+    withManagerNS,
+    Manager,
+
+    -- * Core types
+    module NationStates.Types,
+
+    ) where
+
+
+import Network.HTTP.Client
+import Network.HTTP.Client.TLS
+
+import NationStates.Types
+
+
+-- | Construct a connection 'Manager', with settings tailored to the
+-- NationStates API.
+--
+-- @
+-- withManagerNS = 'withManager' 'tlsManagerSettings'
+-- @
+withManagerNS :: (Manager -> IO a) -> IO a
+withManagerNS = withManager tlsManagerSettings

NationStates/Core.hs

@@ -0,0 +1,138 @@
+module NationStates.Core (
+
+    NS,
+    makeNS,
+    requestNS,
+
+    Query(..),
+    queryToUrl,
+    Parser,
+
+    simpleField,
+    splitDropBlanks,
+    Manager,
+
+    readMaybe,
+    expect,
+    expected,
+
+    module NationStates.Types,
+
+    ) where
+
+
+import qualified Data.ByteString.Char8 as BC
+import Data.Functor.Compose
+import Data.Foldable (toList)
+import Data.List
+import Data.List.Split
+import Data.Monoid
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Network.HTTP.Client
+import qualified Network.HTTP.Types as HTTP
+import Text.Read
+import Text.XML.Light
+
+import NationStates.Types
+
+
+type NS = Compose ((,) Query) Parser
+
+-- | Construct a request for a single shard.
+makeNS
+    :: String
+        -- ^ Shard name
+    -> Maybe Integer
+        -- ^ Shard ID
+    -> [(String, String)]
+        -- ^ List of options
+    -> (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
+    }, parse)
+
+
+-- | Perform a request on the NationStates API.
+requestNS
+    :: Maybe (String, String)
+        -- ^ Request type
+    -> NS a
+        -- ^ Set of shards to request
+    -> Manager
+    -> IO a
+requestNS kindAndName (Compose (q, p)) man
+    = parse . responseBody <$> httpLbs req man
+  where
+    parse = p . fromMaybe (error "invalid response") . parseXMLDoc
+    req = initRequest {
+        queryString
+            = HTTP.renderQuery True (HTTP.toQuery $
+                toList kindAndName ++ [("q", shards)])
+            <> BC.pack options
+        }
+    (shards, options) = queryToUrl q
+
+initRequest :: Request
+Just initRequest = parseUrl "https://www.nationstates.net/cgi-bin/api.cgi"
+
+
+data Query = Query {
+    queryShards :: Map String (Maybe (Set Integer)),
+    queryOptions :: Map String String
+    } deriving Show
+
+instance Monoid Query where
+    mempty = Query mempty mempty
+    mappend a b = Query {
+        queryShards = Map.unionWithKey mergeShards
+            (queryShards a) (queryShards b),
+        queryOptions = Map.unionWithKey mergeOptions
+            (queryOptions a) (queryOptions b)
+        }
+      where
+        mergeShards _ Nothing Nothing = Nothing
+        mergeShards _ (Just is) (Just is') = Just $ Set.union is is'
+        mergeShards name _ _
+            = error $ "conflicting requests for shard " ++ show name
+        mergeOptions key _ _
+            = error $ "conflicting values for option " ++ show key
+
+
+queryToUrl :: Query -> (String, String)
+queryToUrl q = (shards, options)
+  where
+    shards = intercalate "+" [ fullName |
+        (name, is) <- Map.toList $ queryShards q,
+        fullName <- case is of
+            Nothing -> [name]
+            Just is' -> [ name ++ "-" ++ show i | i <- Set.toList is' ] ]
+    options = concat [ ";" ++ k ++ "=" ++ v |
+        (k, v) <- Map.toList $ queryOptions q ]
+
+
+type Parser = (->) Element
+
+
+simpleField :: String -> Maybe Integer -> String -> NS String
+simpleField shard maybeId elemName = makeNS shard maybeId [] parser
+  where
+    parser = strContent . fromMaybe errorMissing . findChild (unqual elemName)
+    errorMissing = error $ "missing <" ++ elemName ++ "> element"
+
+splitDropBlanks :: Eq a => [a] -> [a] -> [[a]]
+splitDropBlanks = split . dropBlanks . dropDelims . onSublist
+
+
+expect :: String -> (String -> Maybe a) -> String -> a
+expect want parse = fromMaybe <$> expected want <*> parse
+
+expected :: String -> String -> a
+expected want s = error $ "invalid " ++ want ++ ": " ++ show s

NationStates/Nation.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module NationStates.Nation (
+
+    Nation(..),
+    run,
+
+    name,
+    fullname,
+    wa,
+    type_,
+    motto,
+    category,
+    endorsements,
+
+    ) where
+
+
+import Data.Char
+
+import NationStates.Core
+
+
+newtype Nation a = Nation { unNation :: NS a }
+    deriving (Functor, Applicative)
+
+
+run :: String -> Nation a -> Manager -> IO a
+run nation = requestNS (Just ("nation", nation)) . unNation
+
+
+name :: Nation String
+name = Nation $ simpleField "name" Nothing "NAME"
+
+fullname :: Nation String
+fullname = Nation $ simpleField "fullname" Nothing "FULLNAME"
+
+type_ :: Nation String
+type_ = Nation $ simpleField "type" Nothing "TYPE"
+
+motto :: Nation String
+motto = Nation $ simpleField "motto" Nothing "MOTTO"
+
+category :: Nation WACategory
+category = Nation . fmap parse $ simpleField "category" Nothing "CATEGORY"
+  where
+    parse = expect "category" readWACategory
+
+wa :: Nation Bool
+wa = Nation . fmap parse $ simpleField "wa" Nothing "UNSTATUS"
+  where
+    parse "WA Member" = True
+    parse "Non-member" = False
+    parse s = expected "WA status" s
+
+endorsements :: Nation [String]
+endorsements = Nation . fmap (splitDropBlanks ",") $
+    simpleField "endorsements" Nothing "ENDORSEMENTS"

NationStates/Types.hs

@@ -0,0 +1,99 @@
+module NationStates.Types where
+
+
+data WACategory
+    = Anarchy
+    | AuthoritarianDemocracy
+    | BenevolentDictatorship
+    | CapitalistParadise
+    | Capitalizt
+    | CivilRightsLovefest
+    | CompulsoryConsumeristState
+    | ConservativeDemocracy
+    | CorporateBordello
+    | CorporatePoliceState
+    | CorruptDictatorship
+    | DemocraticSocialists
+    | FatherKnowsBestState FatherOrMother
+    | FreeMarketParadise
+    | InoffensiveCentristDemocracy
+    | IronFistConsumerists
+    | IronFistSocialists
+    | LeftLeaningCollegeState
+    | LeftWingUtopia
+    | LiberalDemocraticSocialists
+    | LibertarianPoliceState
+    | MoralisticDemocracy
+    | NewYorkTimesDemocracy
+    | PsychoticDictatorship
+    | RightWingUtopia
+    | ScandinavianLiberalParadise
+    | TyrannyByMajority
+    deriving (Eq, Ord, Read, Show)
+
+data FatherOrMother = Father | Mother
+    deriving (Eq, Ord, Read, Show, Bounded, Enum)
+
+
+readWACategory :: String -> Maybe WACategory
+readWACategory s = case s of
+    "Anarchy" -> Just Anarchy
+    "Authoritarian Democracy" -> Just AuthoritarianDemocracy
+    "Benevolent Dictatorship" -> Just BenevolentDictatorship
+    "Capitalist Paradise" -> Just CapitalistParadise
+    "Capitalizt" -> Just Capitalizt
+    "Civil Rights Lovefest" -> Just CivilRightsLovefest
+    "Compulsory Consumerist State" -> Just CompulsoryConsumeristState
+    "Conservative Democracy" -> Just ConservativeDemocracy
+    "Corporate Bordello" -> Just CorporateBordello
+    "Corporate Police State" -> Just CorporatePoliceState
+    "Corrupt Dictatorship" -> Just CorruptDictatorship
+    "Democratic Socialists" -> Just DemocraticSocialists
+    "Father Knows Best State" -> Just $ FatherKnowsBestState Father
+    "Free-Market Paradise" -> Just FreeMarketParadise
+    "Inoffensive Centrist Democracy" -> Just InoffensiveCentristDemocracy
+    "Iron Fist Consumerists" -> Just IronFistConsumerists
+    "Iron Fist Socialists" -> Just IronFistSocialists
+    "Left-Leaning College State" -> Just LeftLeaningCollegeState
+    "Left-wing Utopia" -> Just LeftWingUtopia
+    "Liberal Democratic Socialists" -> Just LiberalDemocraticSocialists
+    "Libertarian Police State" -> Just LibertarianPoliceState
+    "Moralistic Democracy" -> Just MoralisticDemocracy
+    "Mother Knows Best State" -> Just $ FatherKnowsBestState Mother
+    "New York Times Democracy" -> Just NewYorkTimesDemocracy
+    "Psychotic Dictatorship" -> Just PsychoticDictatorship
+    "Right-wing Utopia" -> Just RightWingUtopia
+    "Scandinavian Liberal Paradise" -> Just ScandinavianLiberalParadise
+    "Tyranny by Majority" -> Just TyrannyByMajority
+    _ -> Nothing
+
+showWACategory :: WACategory -> String
+showWACategory c = case c of
+    Anarchy -> "Anarchy"
+    AuthoritarianDemocracy -> "Authoritarian Democracy"
+    BenevolentDictatorship -> "Benevolent Dictatorship"
+    CapitalistParadise -> "Capitalist Paradise"
+    Capitalizt -> "Capitalizt"
+    CivilRightsLovefest -> "Civil Rights Lovefest"
+    CompulsoryConsumeristState -> "Compulsory Consumerist State"
+    ConservativeDemocracy -> "Conservative Democracy"
+    CorporateBordello -> "Corporate Bordello"
+    CorporatePoliceState -> "Corporate Police State"
+    CorruptDictatorship -> "Corrupt Dictatorship"
+    DemocraticSocialists -> "Democratic Socialists"
+    FatherKnowsBestState Father -> "Father Knows Best State"
+    FatherKnowsBestState Mother -> "Mother Knows Best State"
+    FreeMarketParadise -> "Free-Market Paradise"
+    InoffensiveCentristDemocracy -> "Inoffensive Centrist Democracy"
+    IronFistConsumerists -> "Iron Fist Consumerists"
+    IronFistSocialists -> "Iron Fist Socialists"
+    LeftLeaningCollegeState -> "Left-Leaning College State"
+    LeftWingUtopia -> "Left-wing Utopia"
+    LiberalDemocraticSocialists -> "Liberal Democratic Socialists"
+    LibertarianPoliceState -> "Libertarian Police State"
+    MoralisticDemocracy -> "Moralistic Democracy"
+    NewYorkTimesDemocracy -> "New York Times Democracy"
+    PsychoticDictatorship -> "Psychotic Dictatorship"
+    RightWingUtopia -> "Right-wing Utopia"
+    ScandinavianLiberalParadise -> "Scandinavian Liberal Paradise"
+    TyrannyByMajority -> "Tyranny by Majority"

nationstates.cabal

@@ -0,0 +1,40 @@
+name: nationstates
+version: 0
+synopsis: NationStates API client
+description:
+    NationStates API client
+
+homepage: https://github.com/lfairy/nationstates
+author: Chris Wong
+maintainer: lambda.fairy@gmail.com
+copyright: 2015 Chris Wong
+license: Apache-2.0
+category: Network, Web
+
+build-type: Simple
+cabal-version: >= 1.10
+extra-source-files: README.md
+
+library
+    exposed-modules:
+        NationStates
+        NationStates.Core
+        NationStates.Nation
+    other-modules:
+        NationStates.Types
+    build-depends:
+        base >= 4.8 && < 5,
+        bytestring,
+        containers,
+        http-client,
+        http-client-tls,
+        http-types,
+        split,
+        transformers,
+        xml
+    default-language: Haskell2010
+    ghc-options: -Wall
+
+source-repository head
+    type: git
+    location: https://github.com/lfairy/nationstates.git