Permalink
Browse files

Upgraded to Happstack

  • Loading branch information...
1 parent 96b1e12 commit 3bb59ae991b3221fd13930cf50d7df02a1158b8b @eelco committed Apr 19, 2009
Showing with 17 additions and 81 deletions.
  1. +0 −50 Cookies.hs
  2. +6 −5 LastFm.hs
  3. +2 −2 Luisterpaal.fm.cabal
  4. +9 −24 Luisterpaal.hs
View
@@ -1,50 +0,0 @@
-module Cookies (parseCookies) where
-
-import HAppS.Server.Cookie (Cookie(..))
-
-import Data.Char (chr)
-import Data.List ((\\))
-
-import Control.Applicative
-import Control.Monad (MonadPlus(..), ap)
--- Hide Parsec's definitions of some Applicative functions.
-import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))
-
--- Every Monad is an Applicative.
-instance Applicative (GenParser s a) where
- pure = return
- (<*>) = ap
-
--- Every MonadPlus is an Alternative.
-instance Alternative (GenParser s a) where
- empty = mzero
- (<|>) = mplus
-
--- Less complete but more robust way of parsing cookies. Note: not RFC 2068 compliant!
-parseCookies :: String -> [Cookie]
-parseCookies str = either (const []) id $ parse cookiesParser "" str
-
-cookiesParser = av_pairs
- where -- Parsers based on RFC 2109
- av_pairs = (:) <$> av_pair <*> many (char ';' *> av_pair)
- av_pair = cookie <$> attr <*> option "" (char '=' *> value)
- attr = spaces *> token
- value = word
- word = incomp_token <|> quoted_string
-
- -- Parsers based on RFC 2068
- token = many1 $ oneOf ((chars \\ ctl) \\ tspecials)
- quoted_string = char '"' *> many (oneOf qdtext) <* char '"'
-
- -- Custom parser, incompatible with RFC 2068, but very forgiving ;)
- incomp_token = many1 $ oneOf ((chars \\ ctl) \\ "\";")
-
- -- Primitives from RFC 2068
- tspecials = "()<>@,;:\\\"/[]?={} \t"
- ctl = map chr (127:[0..31])
- chars = map chr [0..127]
- octet = map chr [0..255]
- text = octet \\ ctl
- qdtext = text \\ "\""
-
-cookie key value = Cookie "" "" "" key value
View
@@ -15,8 +15,9 @@ import qualified Text.JSON as J
import Text.JSON
import Network.URI
-import qualified Network.HTTP as H
import Network.HTTP
+import qualified Network.Stream as N
+import Network.Stream
-- Configuration
@@ -58,14 +59,14 @@ lookupObj key = maybe (Error $ "Key '" ++ key ++ "' not found in object") readJS
. lookup key
. fromJSObject
-decode' :: (JSON a) => String -> H.Result a
+decode' :: (JSON a) => String -> N.Result a
decode' = convertResult . decode
where convertResult (Ok a) = Right a
convertResult (Error e) = Left $ ErrorMisc e
-- Session
-getSession :: ClientConf -> Token -> IO (H.Result Session)
+getSession :: ClientConf -> Token -> IO (N.Result Session)
getSession conf token = do
result <- simpleHTTP $ Request (api_uri { uriQuery = sessionRequest conf token }) GET [] ""
case result of
@@ -91,7 +92,7 @@ signRequest params secret = md5sum $ U.fromString $ concatMap (\(k, v) -> k ++ v
-- Handshake
-getHandshake :: ClientConf -> Session -> IO (H.Result Handshake)
+getHandshake :: ClientConf -> Session -> IO (N.Result Handshake)
getHandshake conf session = do
query <- handshakeQuery conf session
result <- simpleHTTP $ Request (post_uri { uriQuery = query }) GET [] ""
@@ -120,7 +121,7 @@ handshakeQuery conf (Session username session_key) = do
]
where (*) = (,)
-parseHandshake :: String -> H.Result Handshake
+parseHandshake :: String -> N.Result Handshake
parseHandshake response = case lines response of
["OK", key, npurl, surl] -> Right $ Handshake key npurl surl
err -> Left $ ErrorMisc ("Handshake failed: " ++ (unlines err))
View
@@ -10,7 +10,7 @@ Build-Type: Simple
Build-Depends: base
, containers
, mtl
- , HAppS-Server >= 0.9.3
+ , happstack-server == 0.2.*
, parsec == 2.*
, bytestring == 0.9.*
, HTTP >= 3001
@@ -26,4 +26,4 @@ Data-Files: static/luisterpaal.js
, static/style.css
Executable: Luisterpaal
Main-Is: Luisterpaal.hs
-Other-Modules: LastFm, Pages, Cookies
+Other-Modules: LastFm, Pages
View
@@ -2,27 +2,26 @@
import Control.Monad
import Control.Monad.Trans
+import Control.Monad.Reader
import System.Environment
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
-import HAppS.Server
+import Happstack.Server
import LastFm
import Pages
-import Cookies
main :: IO ()
main = do
conf <- getClientConf
- simpleHTTP (nullConf { port = 8016 }) $ serve
- [ withData (\token -> [ anyRequest $ createSession conf token ]) -- Callback URL
- , withData (\session -> [anyRequest $ shakeHands conf session])
+ simpleHTTP (nullConf { port = 8016 }) $ msum
+ [ withData (\token -> anyRequest $ createSession conf token) -- Callback URL
+ , withData (\session -> anyRequest $ shakeHands conf session)
- , root [ withDataFn userCookie (\user -> [ anyRequest $ respond ok $ welcomeBack user ])
+ , root $ withDataFn userCookie (\user -> anyRequest $ respond ok $ welcomeBack user)
, anyRequest $ respond ok (welcome $ api_key conf)
- ]
- , dir "proxy" [ proxyServe ["*.audioscrobbler.com:80"] ]
+ , dir "proxy" $ proxyServe ["*.audioscrobbler.com:80"]
, fileServe [] "static"
]
@@ -70,28 +69,14 @@ shakeHands conf session = do
-- Utilities
-root :: Monad m => [ServerPartT m a] -> ServerPartT m a
-root handle = ServerPartT $ \rq -> case rqPaths rq of
- [] -> unServerPartT (multi handle) rq
- _ -> noHandle
+root :: (Monad m) => ServerPartT m a -> ServerPartT m a
+root handler = askRq >>= \rq -> if null $ rqPaths rq then handler else mzero
redir :: String -> Web Response
redir u = found u (toResponse "")
respond :: ToMessage a => (Response -> Web Response) -> a -> Web Response
respond with = with . toResponse
-serve :: [ServerPart a] -> [ServerPart a]
-serve handle = [ ServerPartT $ \rq -> unServerPartT (multi handle) (fixCookies rq) ]
-
-fixCookies :: Request -> Request
-fixCookies req =
- if rqCookies req == []
- then case lookHeader "cookie" $ rqHeaders req of
- Nothing -> req
- Just cookies -> req { rqCookies = cookiefy $ parseCookies cookies }
- else req
- where cookiefy cs = zip (map cookieName cs) cs
-
lookHeader :: String -> Headers -> Maybe String
lookHeader name headers = M.lookup (B.pack name) headers >>= return . B.unpack . head . hValue

0 comments on commit 3bb59ae

Please sign in to comment.