module NationStates.Core (
NS,
makeNS,
makeNS',
requestNS,
apiVersion,
Query(..),
Context(..),
wordsBy,
readMaybe,
expect,
expected,
module NationStates.Types,
) where
import Control.Applicative
import qualified Data.ByteString.Char8 as BC
import Data.Functor.Compose
import qualified Data.Foldable as F
import Data.List
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 Prelude
import NationStates.Types
type NS = Compose ((,) Query) (Compose ((->) Query) ((->) Element))
makeNS
:: String
-> String
-> NS String
makeNS shard elemName = makeNS' shard Nothing [] parse
where
parse _ = strContent . fromMaybe errorMissing . findChild (unqual elemName)
errorMissing = error $ "missing <" ++ elemName ++ "> element"
makeNS'
:: String
-> Maybe Integer
-> [(String, String)]
-> (Query -> Element -> a)
-> NS a
makeNS' name maybeId options parse = Compose
(Query {
queryShards = Map.singleton name (Set.singleton maybeId),
queryOptions = Map.fromList options
}, Compose parse)
requestNS
:: Maybe (String, String)
-> NS a
-> Context
-> IO a
requestNS kindAndName (Compose (q, Compose p)) c
= parse . responseBody <$>
(contextRateLimit c $ httpLbs req (contextManager c))
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,
requestHeaders
= ("User-Agent", BC.pack $ contextUserAgent c)
: requestHeaders initRequest
}
(shards, options) = queryToUrl q
initRequest :: Request
Just initRequest = parseUrl "https://www.nationstates.net/cgi-bin/api.cgi"
apiVersion :: Integer
apiVersion = 7
data Context = Context {
contextManager :: Manager,
contextRateLimit :: forall a. IO a -> IO a,
contextUserAgent :: String
}
data Query = Query {
queryShards :: Map String (Set (Maybe Integer)),
queryOptions :: Map String String
} deriving Show
instance Monoid Query where
mempty = Query mempty mempty
mappend a b = Query {
queryShards = Map.unionWith Set.union
(queryShards a) (queryShards b),
queryOptions = Map.unionWithKey mergeOptions
(queryOptions a) (queryOptions b)
}
where
mergeOptions key _ _
= error $ "conflicting values for option " ++ show key
queryToUrl :: Query -> (String, String)
queryToUrl q = (shards, options)
where
shards = 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 ]
wordsBy :: (a -> Bool) -> [a] -> [[a]]
wordsBy p s = case dropWhile p s of
[] -> []
s' ->
let (w, s'') = break p s'
in w : wordsBy p s''
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