Add a new JSON interface
This commit is contained in:
parent
3430a78f61
commit
9904ad9e0c
@ -44,12 +44,25 @@ app runner = do
|
|||||||
respond $ redirectTo (BS.pack url)
|
respond $ redirectTo (BS.pack url)
|
||||||
Nothing -> respond notFound
|
Nothing -> respond notFound
|
||||||
|
|
||||||
post "/short" $ do
|
post "/" $ do
|
||||||
form <- fmap fst parseForm
|
form <- fst <$> parseForm
|
||||||
case lookup "url" form of
|
case lookup "url" form of
|
||||||
|
Nothing -> respond badRequest
|
||||||
Just url' -> do
|
Just url' -> do
|
||||||
let url = BS.unpack url'
|
let url = BS.unpack url'
|
||||||
name <- liftIO (insert table url)
|
name <- liftIO (insert table url)
|
||||||
logStr (printf "Registered %s -> %s " url name)
|
logStr (printf "Registered %s -> %s " url name)
|
||||||
render done $ object ["link" .= (bindUrl ++ name)]
|
render done $ object ["link" .= (bindUrl ++ name)]
|
||||||
Nothing -> respond badRequest
|
|
||||||
|
post "/api" $ do
|
||||||
|
form <- fst <$> parseForm
|
||||||
|
case lookup "url" form of
|
||||||
|
Nothing -> respond badRequest
|
||||||
|
Just url' -> do
|
||||||
|
let url = BS.unpack url'
|
||||||
|
name <- liftIO (insert table url)
|
||||||
|
logStr (printf "Registered %s -> %s " url name)
|
||||||
|
let json = object [ "link" .= (bindUrl ++ name)
|
||||||
|
, "name" .= name
|
||||||
|
, "original" .= url ]
|
||||||
|
respond $ okHtml (encode json)
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
<form action="/short" method="POST">
|
<form method="POST">
|
||||||
your url: <input type="text" name="url">
|
your url: <input type="text" name="url">
|
||||||
<input type="submit" value="go">
|
<input type="submit" value="go">
|
||||||
</form>
|
</form>
|
Loading…
Reference in New Issue
Block a user