Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Newtype wrapper for access tokens

(this would have helped me find a bug involving argument ordering)
  • Loading branch information...
commit 2e28dd177abd488ba15168db62db61bccc83e191 1 parent c5d6941
@timjb authored
View
5 DocumentManager.hs
@@ -13,7 +13,8 @@ import Network.HTTP.Conduit (Manager)
import Control.Concurrent.MVar (MVar, newMVar)
import Control.OperationalTransformation.Text (TextOperation)
import Control.OperationalTransformation.Server (ServerState (..), initialServerState)
-import Helpers (getDriveFileContents)
+import GoogleOAuth2 (AccessToken)
+import Drive (getDriveFileContents)
data DocumentManager = DocumentManager
{ dmServerState :: MVar (ServerState Text TextOperation)
@@ -23,7 +24,7 @@ data DocumentManager = DocumentManager
data DocumentManagerMsg = NewOperation TextOperation deriving (Eq, Show, Read)
-startDocumentManager :: Text -- ^ Authentication token
+startDocumentManager :: AccessToken
-> Text -- ^ File ID
-> Manager -- ^ HTTP Manager
-> IO DocumentManager
View
35 Drive.hs
@@ -0,0 +1,35 @@
+module Drive
+ ( getDriveFileContents
+ ) where
+
+import Prelude
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text as T
+import qualified Google.Drive.V2 as Drive
+import qualified Google.Drive.V2.Types as DriveT
+import Network.HTTP.Conduit (Manager, httpLbs, responseBody, Request (..), parseUrl)
+import Network.HTTP.Types (hAuthorization)
+import Data.ByteString.Lazy (toChunks)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Default (def)
+import Data.Conduit (runResourceT)
+import Data.Text (Text, unpack)
+import Data.Monoid ((<>))
+import Control.Applicative ((<$>))
+import GoogleOAuth2 (AccessToken (..))
+
+getDriveFileContents :: AccessToken
+ -> Text -- ^ File ID
+ -> Manager -- ^ HTTP Manager
+ -> IO Text
+getDriveFileContents (AccessToken at) fileId manager = do
+ let params = def { Drive.parameterOauth_token = Just at }
+ file <- responseBody <$> Drive.getFile params fileId
+ downloadUrl <- maybe (fail "couldn't retrieve file download URL") return $ DriveT.fileDownloadUrl file
+ runResourceT $ do
+ req <- parseUrl $ unpack downloadUrl
+ let authHeader = (hAuthorization, "Bearer " <> encodeUtf8 at)
+ req' = req { requestHeaders = authHeader : requestHeaders req }
+ lazyByteStringToText . responseBody <$> httpLbs req' manager
+ where
+ lazyByteStringToText = T.concat . map decodeUtf8 . toChunks
View
7 Foundation.hs
@@ -24,6 +24,7 @@ import qualified Data.Map as M
import Control.Concurrent.MVar (MVar, takeMVar, putMVar)
import DocumentManager (DocumentManager, startDocumentManager)
import Control.Exception (onException)
+import GoogleOAuth2 (AccessToken (..))
-- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
@@ -167,18 +168,18 @@ instance YesodAuth App where
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
-requireAccessToken :: Handler Text
+requireAccessToken :: Handler AccessToken
requireAccessToken = do
Entity _ user <- requireAuth
case userAccessToken user of
Nothing -> redirect $ AuthR forwardR -- TODO: use refresh token?
- Just at -> return at
+ Just at -> return $ AccessToken at
-- | Get the 'Extra' value, used to hold data from the settings.yml file.
getExtra :: Handler Extra
getExtra = fmap (appExtra . settings) getYesod
-getDocumentManager :: Text -- ^ Authentication token
+getDocumentManager :: AccessToken
-> Text -- ^ File ID
-> Handler DocumentManager
getDocumentManager at fileId = do
View
11 GoogleOAuth2.hs
@@ -1,5 +1,6 @@
module GoogleOAuth2
- ( GoogleOAuth2Settings (..)
+ ( AccessToken (..)
+ , GoogleOAuth2Settings (..)
, forwardR
, callbackR
, getGoogleCreds
@@ -38,9 +39,11 @@ instance FromJSON GoogleOAuth2Settings where
parseJSON _ = fail "google authentication information must be an object"
+newtype AccessToken = AccessToken { unAccessToken :: Text } deriving (Eq, Show, Read, FromJSON)
+
data GoogleToken = GoogleToken
{ googleTokenType :: Maybe Text
- , googleAccessToken :: Text
+ , googleAccessToken :: AccessToken
, googleRefreshToken :: Maybe Text
} deriving (Eq, Show, Read)
@@ -81,11 +84,11 @@ getGoogleCreds gOAuth redirR code = do
token <- runResourceT $ do
res <- http req' (authHttpManager app)
conduitAeson $ responseBody res
- let userinfoParams = def { Oauth2.parameterOauth_token = Just (googleAccessToken token) }
+ let userinfoParams = def { Oauth2.parameterOauth_token = Just (unAccessToken $ googleAccessToken token) }
userinfo <- liftIO $ Oauth2.getUserinfo userinfoParams
let userId = maybe "" id $ Oauth2T.userinfoId $ responseBody userinfo
return $ Creds name userId $ catMaybes
- [ Just ("access_token", googleAccessToken token)
+ [ Just ("access_token", unAccessToken $ googleAccessToken token)
, (,) "refresh_token" <$> googleRefreshToken token
]
View
16 Handler/Editor.hs
@@ -25,21 +25,22 @@ import Control.OperationalTransformation.Server (ServerState (..), applyOperatio
import Control.Monad (when)
import Settings.Development (development)
+import GoogleOAuth2 (AccessToken (..))
import DocumentManager (DocumentManager (..))
-authenticate :: Route App -> Handler Text
+authenticate :: Route App -> Handler AccessToken
authenticate route = do
mAuth <- maybeAuth
case mAuth of
- Just (Entity _ (User { userAccessToken = Just at })) -> return at
+ Just (Entity _ (User { userAccessToken = Just at })) -> return $ AccessToken at
_ -> do
code <- requireGetParam "code"
app <- getYesod
let gOAuthSettings = extraGoogleOAuth2 $ appExtra $ settings app
creds@(Creds _ _ extra) <- getGoogleCreds gOAuthSettings route code
_ <- getAuthId creds
- return $ fromJust $ lookup "access_token" extra
+ return $ AccessToken $ fromJust $ lookup "access_token" extra
requireGetParam :: Text -> Handler Text
@@ -70,11 +71,11 @@ instance FromJSON EditState where
_ -> fail $ "unknown action: " ++ unpack action
parseJSON v = typeMismatch "object" v
-updateFile :: Text -- ^ Access Token
+updateFile :: AccessToken
-> Text -- ^ File ID
-> Text -- ^ content
-> Handler ()
-updateFile at fileId content = do
+updateFile (AccessToken at) fileId content = do
app <- getYesod
liftIO $ runResourceT $ do
req <- parseUrl $ "https://www.googleapis.com/upload/drive/v2/files/" ++ unpack fileId
@@ -89,11 +90,11 @@ updateFile at fileId content = do
getContent :: EditState
- -> Text -- ^ Access token
+ -> AccessToken
-> Handler (Text, Integer, Text) -- ^ File ID, Current revision number and content
getContent (CreateState parentId) at = do
let content = "This is a Markdown document."
- let params = def { Drive.parameterOauth_token = Just at }
+ let params = def { Drive.parameterOauth_token = Just (unAccessToken at) }
let parent = DriveT.ParentReference
{ DriveT.parentReferenceParentLink = Nothing
, DriveT.parentReferenceIsRoot = Nothing
@@ -120,7 +121,6 @@ getEditR = do
state <- requireJsonGetParam "state" :: Handler EditState
(fileId, revision, content) <- getContent state accessToken
liftIO $ putStrLn "Guten Tag Welt!"
- accessToken <- authenticate EditR
defaultLayout $ do
setTitle "Edit"
addStylesheet $ StaticR codemirror_lib_codemirror_css
View
7 Handler/Welcome.hs
@@ -6,12 +6,13 @@ import qualified Google.Oauth2.V2 as Oauth2
import qualified Google.Oauth2.V2.Types as Oauth2T
import Data.Default (Default (..))
import Network.HTTP.Conduit (Response (..))
+import GoogleOAuth2 (AccessToken (..))
getWelcomeR :: Handler RepHtml
getWelcomeR = do
- accessToken <- requireAccessToken
- about <- liftIO $ Drive.getAbout $ def { Drive.parameterOauth_token = Just accessToken }
- userinfo <- liftIO $ Oauth2.getUserinfo $ def { Oauth2.parameterOauth_token = Just accessToken }
+ AccessToken at <- requireAccessToken
+ about <- liftIO $ Drive.getAbout $ def { Drive.parameterOauth_token = Just at }
+ userinfo <- liftIO $ Oauth2.getUserinfo $ def { Oauth2.parameterOauth_token = Just at }
let name = maybe "" (" " <>) $ Oauth2T.userinfoName $ responseBody userinfo
defaultLayout $ do
setTitle "Welcome to Neoprene!"
View
30 Helpers.hs
@@ -1,6 +1,5 @@
module Helpers
( conduitAeson
- , getDriveFileContents
) where
import Prelude
@@ -10,19 +9,6 @@ import Data.Conduit (ResumableSource, ($$+-))
import Data.Conduit.Attoparsec (sinkParser)
import Control.Monad.Trans.Resource (MonadThrow)
import Data.ByteString (ByteString)
-import Data.Text.Encoding (encodeUtf8)
-import qualified Data.Text as T
-import qualified Google.Drive.V2 as Drive
-import qualified Google.Drive.V2.Types as DriveT
-import Network.HTTP.Conduit (Manager, httpLbs, responseBody, Request (..), parseUrl)
-import Network.HTTP.Types (hAuthorization)
-import Data.ByteString.Lazy (toChunks)
-import Data.Text.Encoding (decodeUtf8)
-import Data.Default (def)
-import Data.Conduit (runResourceT)
-import Data.Text (Text, unpack)
-import Data.Monoid ((<>))
-import Control.Applicative ((<$>))
conduitAeson :: (FromJSON a, Monad m, MonadThrow m)
=> ResumableSource m ByteString
@@ -30,19 +16,3 @@ conduitAeson :: (FromJSON a, Monad m, MonadThrow m)
conduitAeson source = do
jsonValue <- source $$+- sinkParser json
either fail return $ parseEither parseJSON jsonValue
-
-getDriveFileContents :: Text -- ^ Authentication token
- -> Text -- ^ File ID
- -> Manager -- ^ HTTP Manager
- -> IO Text
-getDriveFileContents at fileId manager = do
- let params = def { Drive.parameterOauth_token = Just at }
- file <- responseBody <$> Drive.getFile params fileId
- downloadUrl <- maybe (fail "couldn't retrieve file download URL") return $ DriveT.fileDownloadUrl file
- runResourceT $ do
- req <- parseUrl $ unpack downloadUrl
- let authHeader = (hAuthorization, "Bearer " <> encodeUtf8 at)
- req' = req { requestHeaders = authHeader : requestHeaders req }
- lazyByteStringToText . responseBody <$> httpLbs req' manager
- where
- lazyByteStringToText = T.concat . map decodeUtf8 . toChunks
View
1  neoprene.cabal
@@ -37,6 +37,7 @@ library
Google.Oauth2.V2
Google.Oauth2.V2.Types
Helpers
+ Drive
DocumentManager
if flag(dev) || flag(library-only)
View
2  templates/welcome.hamlet
@@ -1,5 +1,5 @@
<h1>Welcome#{name}!
-<p>Hallo Welt! You have the token #{show accessToken}.
+<p>Hallo Welt! You have the token #{show at}.
<p>About information: #{show about}
<p>Userinfo: #{show userinfo}

0 comments on commit 2e28dd1

Please sign in to comment.
Something went wrong with that request. Please try again.