From 73935d6482011269a5064e6feedc58e7d37b711f Mon Sep 17 00:00:00 2001 From: Chris Wong Date: Thu, 18 Jun 2015 16:13:54 +1200 Subject: [PATCH] First commit --- .gitignore | 9 +++ NationStates.hs | 26 ++++++++ NationStates/Core.hs | 138 +++++++++++++++++++++++++++++++++++++++++ NationStates/Nation.hs | 58 +++++++++++++++++ NationStates/Types.hs | 99 +++++++++++++++++++++++++++++ nationstates.cabal | 40 ++++++++++++ 6 files changed, 370 insertions(+) create mode 100644 .gitignore create mode 100644 NationStates.hs create mode 100644 NationStates/Core.hs create mode 100644 NationStates/Nation.hs create mode 100644 NationStates/Types.hs create mode 100644 nationstates.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..6609826 --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +dist +.cabal-sandbox/ +cabal.sandbox.config +cabal-dev +*.o +*.hi +*.chi +*.chs.h +.virthualenv diff --git a/NationStates.hs b/NationStates.hs new file mode 100644 index 0000000..d4309e0 --- /dev/null +++ b/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 diff --git a/NationStates/Core.hs b/NationStates/Core.hs new file mode 100644 index 0000000..2e8b5e8 --- /dev/null +++ b/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 diff --git a/NationStates/Nation.hs b/NationStates/Nation.hs new file mode 100644 index 0000000..f122b16 --- /dev/null +++ b/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" diff --git a/NationStates/Types.hs b/NationStates/Types.hs new file mode 100644 index 0000000..56e30dd --- /dev/null +++ b/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" diff --git a/nationstates.cabal b/nationstates.cabal new file mode 100644 index 0000000..b743306 --- /dev/null +++ b/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