I'm trying to create a JSON REST api using Happstack. It should allow POSTS with a JSON body. How can I do this? All the functions in happstack's API seem to look things up based on parameter name. It thinks the body is always url-encoded.
If it isn't possible with Happstack, which framework should I use?
Alright, here's what I figured out.
{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
import qualified Data.ByteString.Lazy.Char8 as L
import Happstack.Server
import Happstack.Server.Types
import Control.Monad.IO.Class (liftIO)
import Data.Data (Data, Typeable)
-- easiest to serialize/deserialize objects
data Unit = Unit { x :: Int, y :: Int } deriving (Show, Eq, Data, Typeable)
-- put this function in a library somewhere
getBody :: ServerPart L.ByteString
getBody = do
req <- askRq
body <- liftIO $ takeRequestBody req
case body of
Just rqbody -> return . unBody $ rqbody
Nothing -> return ""
myRoute :: ServerPart Response
myRoute = do
body <- getBody -- it's a ByteString
let unit = fromJust $ A.decode body :: Unit -- how to parse json
ok $ toResponse $ A.encode unit -- how to send json back.
Related
I would like for my default handler to be able to catch all of the exceptions that my App throws but in order for this to happen I need to manually call raise after manually adding some exception catching around my IO code.
below is an example minimal server:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Lib
( someFunc
) where
import Web.Scotty.Trans
import Control.Monad.Trans
import Control.Monad.Reader
import Control.Monad.Catch
import Control.Monad.Except
import Data.Text.Lazy as TL
data AppEnv = AppEnv
{ appStuff :: String
}
newtype App a = App
{ unApp :: ReaderT AppEnv IO a
} deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppEnv, MonadThrow)
someFunc :: IO ()
someFunc = do
let run a = runReaderT (unApp $ App a) (AppEnv "APPY STUFF")
scottyT 8080 run $ do
defaultHandler $ \(e :: TL.Text) -> do
liftIO $ print "HERE"
liftIO $ print $ showError e
html $ "Something Went Seriously Wrong"
get "/" $ do
(r :: (Either TL.Text String)) <- liftIO $ runExceptT $ do
(uId) <- lift $ readFile "./helloworld.txt"
return $ ("hello")
liftIO $ print r
case r of
Left l -> raise l
Right s -> (html "hello world")
get "/catch-this" $ do
error "Catch Me"
(html "hello world")
notFound $ do
html "That is not a valid route"
I would like to be able to catch all of my uncaught exceptions in my default handler however this is not the default behavior of scotty that only happens if you call raise. I could wrap all of my ActionM code blocks in ExceptT however this seems like a messy/mechanical way of solving this problem. I mostly want to do this for logging purposes so I can report out to Sentry or Log to a file and this would make it much more convenient.
I figured I'd throw this in there as I recently was looking for this same solution again. It's unfortunate but I was never able to get the behavior that I wanted out of scotty.
Fortunately since scotty is just a nice library to create WAI application's you can get a nice work around using the Settings type from warp and the Options type from scotty.
Below is an example of how you can approach this:
{-# LANGUAGE OverloadedStrings #-}
module Lib
( someFunc
) where
import Web.Scotty.Trans
import Data.Text
import qualified Data.Text.Lazy as TL
import Control.Monad.IO.Class
import Control.Exception
import Network.HTTP.Types
import System.IO.Error
import Network.Wai.Handler.Warp
import Network.Wai
myOpts :: Options
myOpts = Options 1 mySettings
mySettings :: Settings
mySettings = setOnExceptionResponse myHandler $ setPort 3002 $ defaultSettings
myHandler :: SomeException -> Response
myHandler se = responseLBS status500 [] "HERE WE ARE"
someFunc :: IO ()
someFunc = do
scottyOptsT myOpts id routes
myExceptions :: (MonadIO m) => TL.Text -> ActionT TL.Text m ()
myExceptions t = do
liftIO $ print t
html "error"
routes :: (MonadIO m) => ScottyT TL.Text m ()
routes = do
defaultHandler $ \str -> do
liftAndCatchIO $ print str
status status500
json ("welp you thought"::Text)
get "/:here" $ do
liftIO $ ioError $ userError "Hahah"
text "here"
You can then tap further into the Settings type provided by warp so that you could maybe log all the error messages or perform some custom action using the following methods setOnException setOnExceptionResponse.
I am trying to get back a value that is in a json feed (via Aeson) directly inside a StateT stacked on IO:
{-# LANGUAGE DeriveGeneric #-}
module MyFeed where
import Data.Aeson
import Network.URI (parseURI, URI(..))
import Data.Maybe (fromJust)
import Data.Text (Text, unpack)
import Control.Monad.State
import Network.HTTP
import GHC.Generics
import Control.Applicative
import Network.HTTP.Conduit (simpleHttp)
import qualified Data.ByteString.Lazy as B
type Feed a = StateT MyIndex IO a
data MyIndex = MyIndex {
index :: Int
}
data FooBar = Foo | Bar
data MyFeed = MyFeed {
idx :: !Text,
key :: !Text
} deriving (Show,Generic)
instance FromJSON MyFeed
instance ToJSON MyFeed
getJSON :: String -> IO B.ByteString
getJSON url = simpleHttp url
getFeed :: String -> IO (Maybe MyFeed)
getFeed url = (decode <$> getJSON url) :: IO (Maybe MyFeed)
getIndex :: FooBar -> Feed MyIndex
getIndex fb = do
cursor <- get
let newCursor = case fb of
Foo -> do myFeed <- liftIO $ getFeed "http://echo.jsontest.com/key/value/idx/1"
let i = read $ unpack $ idx $ fromJust myFeed
return $ cursor { index = i }
Bar -> return cursor
put newCursor
return newCursor
In the Foo case I fetch the feed as expected but when the required value is returned I get:
src/MyFeed.hs:47:10:
Couldn't match expected type ‘MyIndex’
with actual type ‘m0 MyIndex’
Relevant bindings include
newCursor :: m0 MyIndex (bound at src/MyFeed.hs:40:7)
In the first argument of ‘return’, namely ‘newCursor’
In a stmt of a 'do' block: return newCursor
The Actual Type looks still in a Monad context (do {...}). Is there a way to take it out or I am using a wrong approach?
The error was due to the fact I used:
let newCursor = case fb of
instead of
newCursor <- case fb of
For this reason the final value never get "unwrapped" from its monad context.
I have a JSON request in the style of
{"command":"get","params":{"something":"something else"}}
and this code snippet from the Yesod book
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai (Response, responseLBS, Application, requestBody)
import Network.HTTP.Types (status200, status400)
import Network.Wai.Handler.Warp (run)
import Data.Aeson.Parser (json)
import Data.Conduit.Attoparsec (sinkParser)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (Value(..), encode, object, (.=))
import Control.Exception (SomeException)
import Data.ByteString (ByteString)
import Data.Conduit (ResourceT, ($$))
import Control.Exception.Lifted (handle)
main :: IO ()
main = run 3000 app
app :: Application
app req = handle invalidJson $ do
value <- requestBody req $$ sinkParser json
newValue <- liftIO $ modValue value
return $ responseLBS
status200
[("Content-Type", "application/json")]
$ encode newValue
invalidJson :: SomeException -> ResourceT IO Response
invalidJson ex = return $ responseLBS
status400
[("Content-Type", "application/json")]
$ encode $ object
[ ("message" .= show ex)
]
-- Application-specific logic would go here.
modValue :: Value -> IO Value
modValue (Object o)
| -- key "command" corresponds to value "get"
| otherwise = fail "Invalid command"
But I can't wrap my head around how I would destructure the generated Value data structure. How do I go about getting the values of keys etc. I realise I could parse to an explicitly defined data structure, but that would bring other kinds of problems to my use case.
In modValue I've put a comment where I can't figure out what to put. I tried treating it as a Map, since that's how it is implemented inside Aeson, but that obviously doesn't type check.
EDIT:
Adding Data.HashMap to imports and using the line
| M.lookup "command" o == Just "get" = return $ object [("result" .= (String "YAY"))]
gives the following error message.
main.hs:39:26:
Couldn't match expected type `M.Map k0 a0'
with actual type `aeson-0.6.0.2:Data.Aeson.Types.Internal.Object'
In the second argument of `M.lookup', namely `o'
In the first argument of `(==)', namely `M.lookup "command" o'
In the expression: M.lookup "command" o == Just "get"
EDIT2:
On a sudden hunch, I tracked down an error message I got earlier involving "unordered-containers". This is the package that Aeson uses. But I realised that I also had the package hashmap installed, which is imported as Data.HashMap. The hashmaps from unordered-containers are imported as Data.HashMap.Strict or Lazy!
Changing the line import qualified Data.HashMap as M to import qualified Data.HashMap.Strict as M fixed it anyway. Now the given answer works!
Since an aeson JSON object is a Hashmap, you can use the Hasmap interface, in this case lookup.
import qualified Data.HashMap.Strict as M
M.lookup "command" o == Just "get"
Continuing my exploration of conduit and aeson, how would I go about using my own data type in stead of Value in this (slightly modified) code snippet from the Yesod book.
{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
import Network.Wai (Response, responseLBS, Application, requestBody)
import Network.HTTP.Types (status200, status400)
import Network.Wai.Handler.Warp (run)
import Data.Aeson.Parser (json)
import Data.Conduit.Attoparsec (sinkParser)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (Value(..), encode, object, (.=))
import Control.Exception (SomeException)
import Data.ByteString (ByteString)
import Data.Conduit (ResourceT, ($$))
import Control.Exception.Lifted (handle)
import qualified Data.HashMap.Strict as M
import Data.Aeson.TH (deriveJSON)
-- I ADDED THIS
data JSONRequest = JSONRequest {
command :: ByteString,
params :: M.HashMap ByteString ByteString
}
deriveJSON id ''JSONRequest
-- END OF WHAT I ADDED
main :: IO ()
main = run 3000 app
app :: Application
app req = handle invalidJson $ do
value <- requestBody req $$ sinkParser json
newValue <- liftIO $ dispatch value
return $ responseLBS
status200
[("Content-Type", "application/json")]
$ encode newValue
invalidJson :: SomeException -> ResourceT IO Response
invalidJson ex = return $ responseLBS
status400
[("Content-Type", "application/json")]
$ encode $ object
[ ("message" .= show ex)
]
-- Application-specific logic would go here.
dispatch :: Value -> IO Value
dispatch = return
Basically, I want to change the type of dispatch to JSONRequest -> IO JSONRequest. How do I tell the parser to use my own derived instance of fromJSON?
I tried just adding a type declaration, praying for polymorphic return type on json, but I realised it is strictly for Value.
Just looking at the types, don't you just need to fmap your fromJSON over the result coming from json? With a suitable signature for dispatch we just need:
-- import Data.Aeson
app :: Application
app req = handle invalidJson $ do
result <- requestBody req $$ sinkParser (fmap fromJSON json)
next_result <- liftIO $ dispatch result
return $ responseLBS status200 [("Content-Type", "application/json")]
$ encode next_result
dispatch :: Result JSONRequest -> IO JSONRequest
dispatch (Error str) = undefined
dispatch (Success jsonreq) = return jsonreq
But maybe it's a little clearer written thus:
-- import Data.Aeson
-- import qualified Data.Attoparsec as Atto
toRequest :: Value -> Result JSONRequest
toRequest = fromJSON -- specialized now to your fromJSON
jsonRequestParser :: Atto.Parser (Result JSONRequest)
jsonRequestParser = fmap toRequest json
app :: Application
app req = handle invalidJson $ do
result <- requestBody req $$ sinkParser jsonRequestParser
next_result <- liftIO $ dispatch result
return $ responseLBS status200 [("Content-Type", "application/json")]
$ encode next_result
dispatch :: Result JSONRequest -> IO JSONRequest
dispatch (Error str) = undefined
dispatch (Success jsonreq) = return jsonreq
I left the parser returning a Result JSONRequest so dispatch is handling Error cases too, which might mean you need your exception handling somehow?
Good day, i have mongodb database filled with some data, i ensured that data stored in correct charset, to fetch data i use following snippet:
{-# LANGUAGE OverloadedStrings #-}
import Network.Wai
import Network.Wai.Handler.Warp (run)
import Data.Enumerator (Iteratee (..))
import Data.Either (either)
import Control.Monad (join)
import Data.Maybe (fromMaybe)
import Network.HTTP.Types (statusOK, status404)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Char8 (unpack)
import Data.ByteString.Lazy.Char8 (pack)
import qualified Data.Text.Lazy as T
import Data.Text (Text(..))
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Aeson (encode)
import qualified Data.Map as Map
import qualified Database.MongoDB as DB
application dbpipe req = do
case unpack $ rawPathInfo req of
"/items" -> itemsJSON dbpipe req
_ -> return $ responseLBS status404 [("Content-Type", "text/plain")] "404"
indexPage :: Iteratee B.ByteString IO Response
indexPage = do
page <- liftIO $ processTemplate "templates/index.html" []
return $ responseLBS statusOK [("Content-Type", "text/html; charset=utf-8")] page
processTemplate f attrs = do
page <- L.readFile f
return page
itemsJSON :: DB.Pipe -> Request -> Iteratee B.ByteString IO Response
itemsJSON dbpipe req = do
dbresult <- liftIO $ rundb dbpipe $ DB.find (DB.select [] $ tu "table") >>= DB.rest
let docs = either (const []) id dbresult
-- liftIO $ L.putStrLn $ encode $ show $ map docToMap docs
return $ responseLBS statusOK [("Content-Type", "text/plain; charset=utf-8")]
(encode $ map docToMap docs)
docToMap doc = Map.fromList $ map (\f -> (T.dropAround (== '"') $ T.pack $ show $ DB.label f, T.dropAround (== '"') $ T.pack $ show $ DB.value f)) doc
main = do
pipe <- DB.runIOE $ DB.connect $ DB.host "127.0.0.1"
run 3000 $ application pipe
rundb pipe act = DB.access pipe DB.master database act
tu :: B.ByteString -> UString
tu = DB.u . C8.unpack
Then the result is suprprising, DB.label works well, but DB.value giving me native characters as some escape codes, so the result is look like:
curl http://localhost:3000/items gives:
[{"Марка": "\1058\1080\1087 \1087\1086\1076",
"Model": "BD-W LG BP06LU10 Slim \1058\1080\1087 \1087\1086\1076\1082\1083\1102\1095\1077\1085\1080\1103"},
...
]
This happens in case i trying to print data and also in case i return data encoded as JSON
Any idea how correctly extract values from MongoDB driver ?
The following line confirms that aeson's encoding works properly (using the utf8-string library to read utf8 data off the lazy bytestring back to a haskell string:
> putStrLn $ Data.ByteString.Lazy.UTF8.toString $ encode $ ("\1058\1080\1087 \1087\1086\1076",12)
["Тип под",12]
Looking at your code more closely I see the real problem. You're calling T.pack $ show $ DB.value -- this will render out as literal codepoints, and then pack those into a text object. The fix is to switch from show to something smarter. Look at this (untested)
smartShow :: DB.Value -> Text
smartShow (String s) = Data.Text.Encoding.decodeUtf8 $ Data.CompactString.UTF8.toByteString s
smartShow x = T.pack $ show x
Obviously to handle the recursive cases, etc. you need to be smarter than that, but that's the general notion...
In fact, the "best" thing to do is to write a function of BSON -> JSON directly, rather than go through any intermediate structures at all.
Everything is working as expected -- only your expectations are wrong. =)
What you're seeing there are not raw Strings; they are String's which have been escaped to exist purely in the printable ASCII range by the show function, called by print:
print = putStrLn . show
Never fear: in memory, the string that prints as "\1058" is in fact a single Unicode codepoint long. You can observe this by printing the length of one of the Strings you're interested in and comparing that to the number of Unicode codepoints you expect.