diff --git a/example/demo-server.hs b/example/demo-server.hs new file mode 100644 --- /dev/null +++ b/example/demo-server.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Monad (mzero) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Char (chr) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Conduit hiding (Request, queryString) +import Network.HTTP.Types (Query, status200) +import Network.Wai +import Network.Wai.Handler.Warp (run) +import URI.ByteString (serializeURIRef') +import URI.ByteString.QQ + +import Keys (fitbitKey) +import Network.OAuth.OAuth2 + +import Data.Aeson +import Data.Aeson.Types +import GHC.Generics + +------------------------------------------------------------------------------ + +main :: IO () +main = do + print $ serializeURIRef' $ appendQueryParams [("state", state), ("scope", "profile")] $ authorizationUrl fitbitKey + putStrLn "visit the url to continue" + run 9988 application + +application :: Application +application request respond = do + response <- handleRequest requestPath request + respond $ responseLBS status200 [("Content-Type", "text/plain")] response + where + requestPath = T.intercalate "/" $ pathInfo request + +handleRequest :: Text -> Request -> IO BL.ByteString +handleRequest "favicon.ico" _ = return "" +handleRequest _ request = do + mgr <- newManager tlsManagerSettings + token <- getApiToken mgr $ getApiCode request + print token + user <- getApiUser mgr (accessToken token) + print user + return $ encode user + +getApiCode :: Request -> ExchangeToken +getApiCode request = + case M.lookup "code" queryMap of + Just code -> ExchangeToken $ T.decodeUtf8 code + Nothing -> Prelude.error "request doesn't include code" + where + queryMap = convertQueryToMap $ queryString request + +getApiToken :: Manager -> ExchangeToken -> IO OAuth2Token +getApiToken mgr code = do + result <- doJSONPostRequest mgr fitbitKey url $ body ++ [("state", state)] + case result of + Right token -> return token + Left (e :: OAuth2Error Errors) -> Prelude.error $ show e + where + (url, body) = accessTokenUrl fitbitKey code + +convertQueryToMap :: Query -> M.Map B.ByteString B.ByteString +convertQueryToMap query = + M.fromList $ map normalize query + where + normalize (k, Just v) = (k, v) + normalize (k, Nothing) = (k, B.empty) + +lazyBSToString :: BL.ByteString -> String +lazyBSToString s = map (chr . fromIntegral) (BL.unpack s) diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -1,6 +1,6 @@ Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy -Version: 1.6.2 +Version: 1.6.3 Synopsis: Haskell OAuth2 authentication client @@ -65,7 +65,7 @@ text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, http-conduit >= 2.1 && < 2.4, - http-types >= 0.11 && < 0.12, + http-types >= 0.11 && < 0.13, aeson >= 0.11 && < 1.3, unordered-containers >= 0.2.5, uri-bytestring >= 0.2.3.1 && < 0.4, @@ -90,7 +90,7 @@ hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.12, + http-types >= 0.11 && < 0.13, http-conduit >= 2.1 && < 2.4, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, @@ -116,7 +116,7 @@ hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.12, + http-types >= 0.11 && < 0.13, http-conduit >= 2.1 && < 2.4, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, @@ -142,7 +142,7 @@ hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.12, + http-types >= 0.11 && < 0.13, http-conduit >= 2.1 && < 2.4, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, @@ -167,7 +167,7 @@ hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.12, + http-types >= 0.11 && < 0.13, http-conduit >= 2.1 && < 2.4, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, @@ -192,7 +192,7 @@ hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.12, + http-types >= 0.11 && < 0.13, http-conduit >= 2.1 && < 2.4, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, @@ -221,7 +221,7 @@ bytestring >= 0.9 && < 0.11, uri-bytestring >= 0.2.3.1 && < 0.4, http-conduit >= 2.1 && < 2.4, - http-types >= 0.11 && < 0.12, + http-types >= 0.11 && < 0.13, wai >= 3.2 && < 3.3, warp >= 3.2 && < 3.3, containers >= 0.4 && < 0.6, @@ -246,7 +246,7 @@ hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.12, + http-types >= 0.11 && < 0.13, http-conduit >= 2.1 && < 2.4, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, @@ -271,7 +271,7 @@ hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.12, + http-types >= 0.11 && < 0.13, http-conduit >= 2.1 && < 2.4, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, @@ -296,7 +296,7 @@ hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.12, + http-types >= 0.11 && < 0.13, http-conduit >= 2.1 && < 2.4, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, @@ -307,5 +307,34 @@ if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + +Executable demo-server + if flag(test) + Buildable: True + else + Buildable: False + + main-is: demo-server.hs + other-modules: Keys + hs-source-dirs: example + default-language: Haskell2010 + build-depends: base >= 4.5 && < 5, + text >= 0.11 && < 1.3, + bytestring >= 0.9 && < 0.11, + uri-bytestring >= 0.2.3.1 && < 0.4, + http-conduit >= 2.1 && < 2.4, + http-types >= 0.11 && < 0.13, + wai >= 3.2 && < 3.3, + warp >= 3.2 && < 3.3, + containers >= 0.4 && < 0.6, + aeson >= 0.11 && < 1.3, + hoauth2 + + + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind -fno-warn-orphans else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields