Last active
October 17, 2015 19:54
-
-
Save imalsogreg/dfa352b454c68693f28b to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE DeriveGeneric #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE PolyKinds #-} | |
{-# LANGUAGE TypeFamilies #-} | |
{-# LANGUAGE TypeOperators #-} | |
{-# LANGUAGE TemplateHaskell #-} | |
import Control.Monad (mzero) | |
import Control.Monad.IO.Class (liftIO) | |
import Control.Monad.State (gets) | |
import Control.Lens hiding ((.=)) | |
import Data.Aeson | |
import Data.ByteString.Char8 (pack) | |
import Data.IORef (IORef, newIORef, readIORef, | |
modifyIORef, writeIORef) | |
import Data.Proxy | |
import Data.Text hiding (pack) | |
import GHC.Generics | |
import Servant.Server.Internal.SnapShims | |
import Snap.Core (writeBS) | |
import Snap.Snaplet | |
import Snap.Snaplet.Auth | |
import Snap.Snaplet.Session | |
import Snap.Snaplet.Session.Backends.CookieSession | |
import Snap.Snaplet.Auth.Backends.JsonFile | |
import Snap.Snaplet.Heist | |
import Snap.Http.Server (defaultConfig) | |
import Snap.Http.Server.Config (setPort) | |
import Servant | |
import qualified Servant.JS as JS | |
import qualified Servant.JS.Internal as JSI | |
-- | Our simple class, `Item`, holding a name and a URL | |
data Item = Item | |
{ iname :: Text | |
, iurl :: Text | |
} deriving (Eq, Show, Ord, Generic) | |
-- 'deriving' makes Item a subclass of these other classes, | |
-- so we get `==`, `print`, `<`, and Reflection for `Item` | |
-- | A binary tree class for our `Item`s. | |
-- A single tree may be either: | |
data Tree = | |
TEmpty -- ^ The 'empty' tree | |
| TNode Item Tree Tree -- ^ Or a Node, containing a payload and | |
-- two sub-trees (which may themselves | |
-- be TEmpty or TNode _ _ _). | |
deriving (Eq, Ord, Show, Generic) | |
-- * Basic operations over trees | |
-- | insertT _O(log(n))_ takes an `Item` and an `Tree` and returns | |
-- a new `Tree` with the `Item` inserted. | |
-- We'll define the function in two parts: one for the case | |
-- when the `Tree` is `TEmpty` (the base case), | |
-- and another for the recursive/inductive case | |
insertT :: Item -> Tree -> Tree | |
insertT s TEmpty = TNode s TEmpty TEmpty | |
insertT s (TNode a l r) | |
| iname s < iname a = TNode a (insertT s l) r | |
| iname s >= iname a = TNode a l (insertT s r) | |
-- | deleteT _O(log(n))_ searches a `Tree` for an `Item` with a | |
-- given name, and returns the same tree with that node (and | |
-- all its children) deleted | |
-- Like insertT, deleteT function is defined in parts | |
deleteT :: Text -> Tree -> Tree | |
deleteT _ TEmpty = TEmpty | |
deleteT i (TNode a l r) | |
| i == iname a = TEmpty | |
| i < iname a = TNode a (deleteT i l) r | |
| i > iname a = TNode a l (deleteT i r) | |
-- | lookupT searches a `Tree` for an `Item` with a give name, | |
-- returning that `Item`s URL member if it finds a match, or | |
-- 'Nothing' if there is no match | |
lookupT :: Text -> Tree -> Maybe Text | |
lookupT _ TEmpty = Nothing | |
lookupT i (TNode a l r) | |
| i == iname a = Just $ iurl a | |
| i < iname a = lookupT i l | |
| i > iname a = lookupT i r | |
-- * Serialization | |
-- | How to turn a a `Item` into a JSON string | |
-- e.g. An `Item` with name "greg" and url "google.com" | |
-- should become '{"name":"greg", "url":"google.com"}' | |
instance ToJSON Item where | |
toJSON i = | |
object ["name" .= iname i, "url" .= iurl i] | |
-- | How to recover an `Item` from a JSON string | |
-- This is string parsing, which can be tricky, | |
-- so we will hide some of the complications of | |
-- error reporting and sequencing behind the | |
-- Applicative interface (something to chat | |
-- about later) | |
instance FromJSON Item where | |
parseJSON (Object v) = | |
Item <$> v .: "name" <*> v .: "url" | |
parseJSON _ = mzero | |
-- | The process is the same for turing `Tree`s into | |
-- strings and back. We can let the compiler write | |
-- these conversion functions for us, but let's | |
-- write them ourselves just to see their insides | |
-- | |
-- A `TEmpty` should turn into the JSON `null` value, | |
-- A `TNode` should turn into a JSON `object` with | |
-- three fields: the payload, and (recursively) the | |
-- left and right subtrees | |
instance ToJSON Tree where | |
toJSON TEmpty = Null | |
toJSON (TNode a l r) = object ["payload" .= a | |
, "left" .= toJSON l | |
, "right" .= toJSON r | |
] | |
instance FromJSON Tree where | |
parseJSON Null = pure TEmpty | |
parseJSON (Object v) = | |
TNode <$> | |
v .: "payload" <*> | |
v .: "left" <*> | |
v .: "right" | |
parseJSON _ = mzero | |
-- * The web service | |
-- | API specification | |
-- Sections are mutually exclusive URL's tha the site will process | |
-- A web api is like a set of functions, but messier because | |
-- the 'functions' are called by the user on one computer, (the | |
-- client, usually a web browser), and evaluated on another, (the | |
-- server), then the results are sent back to the client. | |
-- | |
-- The spec we define here provides enough information for us to | |
-- implement the the server, a web browser client, commant-line | |
-- clients, and user-facing documentation | |
type TestApi = | |
-- 'example.com/api/tree' will return a the `Tree` state, JSON | |
-- encoded | |
"tree" :> Get '[JSON] Tree | |
-- 'example.com/api/insert' will look for a JSON encoded `Item` | |
-- in the request body, add it to the tree state, and return | |
-- the new `Tree`, JSON encoded | |
:<|> "insert" :> ReqBody '[JSON] Item :> Post '[JSON] Tree | |
-- 'example.com/api/lookup?id=greg' will call `lookupT` on the | |
-- `Tree` living on the server and return the 'greg' node's | |
-- payload, encoded in JSON of course | |
:<|> "lookup" :> QueryParam "id" Text :> Get '[JSON] Text | |
-- 'example.com/api/delete?id=hunger' behaves similarly to | |
-- 'lookup' above, modifying the server's tree according to | |
-- the output of the `deleteT` function | |
:<|> "delete" :> QueryParam "id" Text :> Get '[JSON] Tree | |
-- 'example.com/api/undo' will swap the server's current and | |
-- backup `Tree`s | |
:<|> "undo" :> Get '[JSON] Tree | |
-- Define a class for our web app, call it `App`, give it | |
-- members for the various web-app things it needs (client sessions, | |
-- cookies, template generation, and our `Tree` member, and an | |
-- extra `Tree` used as a backup or undo operations) | |
data App = App { | |
_heist :: Snaplet (Heist App) | |
, _sess :: Snaplet SessionManager | |
, _auth :: Snaplet (AuthManager App) | |
, _gNow :: IORef Tree | |
, _gLast :: IORef Tree | |
} | |
makeLenses ''App | |
type AppHandler = Handler App App | |
testApi :: Proxy TestApi | |
testApi = Proxy | |
-- Server-side handlers. | |
-- | |
-- There's one handler per endpoint, which, just like in the type | |
-- that represents the API, are glued together using :<|>. | |
-- | |
-- Each handler runs in the 'EitherT ServantErr IO' monad. | |
server :: Server TestApi AppHandler | |
server = getTree :<|> postIns | |
:<|> getLookup :<|> getDel | |
:<|> getUndo | |
where backupState :: AppHandler () | |
backupState = do | |
r <- gets _gNow | |
u <- gets _gLast | |
liftIO $ writeIORef u =<< readIORef r | |
getTree :: AppHandler Tree | |
getTree = do r <- gets _gNow; liftIO $ readIORef r | |
postIns :: Item -> AppHandler Tree | |
postIns v = do | |
backupState | |
r <- gets _gNow | |
t <- liftIO $ readIORef r | |
let t' = insertT v t | |
liftIO $ writeIORef r t' | |
return t' | |
getLookup :: Maybe Text -> AppHandler Text | |
getLookup (Just k) = do | |
r <- gets _gNow | |
t <- liftIO $ readIORef r | |
case lookupT k t of | |
Nothing -> error "Not found" | |
Just t -> return t | |
getDel :: Maybe Text -> AppHandler Tree | |
getDel (Just k) = do | |
backupState | |
r <- gets _gNow | |
liftIO $ modifyIORef r (deleteT k) >> readIORef r | |
getUndo :: AppHandler Tree | |
getUndo = do | |
u <- gets _gLast | |
r <- gets _gNow | |
lastTree <- liftIO $ readIORef u | |
backupState | |
liftIO $ writeIORef r lastTree | |
return lastTree | |
-- Turn the server into a Snap app. 'serve' is provided by servant, | |
-- more precisely by the Servant.Server module. | |
test :: Application AppHandler | |
test = serve testApi server | |
instance HasHeist App where | |
heistLens = subSnaplet heist | |
initApp :: SnapletInit App App | |
initApp = makeSnaplet "myapp" "An example app in servant" Nothing $ do | |
h <- nestSnaplet "" heist $ heistInit "templates" | |
s <- nestSnaplet "sess" sess $ | |
initCookieSessionManager "site_key.txt" "sess" | |
Nothing (Just 3600) | |
a <- nestSnaplet "" auth $ | |
initJsonFileAuthManager defAuthSettings sess "users.json" | |
addRoutes [("api", applicationToSnap test) | |
,("docs", handleDocs) | |
,("", serveDirectory "static")] | |
r <- liftIO $ newIORef TEmpty | |
u <- liftIO $ newIORef TEmpty | |
return $ App h s a r u | |
handleDocs :: Handler App App () | |
handleDocs = writeBS (pack $ JS.jsForAPI testApi (JS.jqueryWith | |
(JS.defCommonGeneratorOptions {JSI.urlPrefix = "api"}))) | |
-- Run the server. | |
-- | |
runTestServer :: Int -> IO () | |
runTestServer port = serveSnaplet (setPort port defaultConfig) | |
initApp | |
-- Put this all to work! | |
main :: IO () | |
main = runTestServer 8001 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
<html><head> | |
<script src="//code.jquery.com/jquery-1.11.3.min.js"></script> | |
<script src="/docs"></script> | |
<style> | |
body { background-color: #eee;} | |
.node-div { background-color: #bbb; } | |
.child-div-left, .child-div-right { width: 49%; margin: 5px; } | |
.child-div-left { } | |
.child-div-right { } | |
.pic-div { display:flex; flex-flow: column nowrap; align-items: center; } | |
.pic { } | |
.pic-label { } | |
.children-div { display: flex; flex-flow: row nowrap;} | |
.node-div { } | |
.hbar { background-color: black; height: 3px; width: 100%;} | |
.vbar { background-color: black; width: 3px; height: 100%;} | |
</style> | |
<script> | |
// Lookup url by name | |
function lclick() { | |
sbox = document.getElementById('lbox'); | |
rbox = document.getElementById('lresponse'); | |
getLookup(sbox.value, function(b) { rbox.innerHTML = b.toString() }, function () { alert('error');}); | |
} | |
// Get the whole tree and render it | |
function fetchAndDraw() { | |
drawingArea = document.getElementById('drawing-area'); | |
drawingArea.innerHTML = ''; | |
getTree( function(r) { drawTree(r, drawingArea, 256); }, function() {alert('Failed');} ); | |
} | |
// Delete item and subtrees by name | |
function dclick() { | |
dbox = document.getElementById('dbox'); | |
getDelete( dbox.value, function(b) {}, function () {alert('error');}); | |
fetchAndDraw(); | |
} | |
// Insert new Item object | |
function iclick() { | |
iname = document.getElementById('ibox'); | |
iurl = document.getElementById('iurl'); | |
b = {}; | |
b.name = iname.value; | |
b.url = iurl.value; | |
postInsert( b, function () { bclick(); }, function () { alert('error') }); | |
} | |
// Render the tree recursively | |
function drawTree(tree,p,len) { | |
if(tree == null) { console.log("Draw null"); } | |
else{ | |
var nodeDiv = document.createElement('div'); | |
nodeDiv.setAttribute('class','node-div'); | |
p.appendChild(nodeDiv); | |
var d = document.createElement('div'); | |
var picdiv = document.createElement('div'); | |
picdiv.setAttribute('class','pic-div'); | |
var picLabel = document.createElement('p'); | |
picLabel.setAttribute('class','pic-label'); | |
picLabel.innerHTML = tree.payload.name; | |
var pic = document.createElement('img'); | |
pic.setAttribute('src', tree.payload.url); | |
pic.setAttribute('class','pic'); | |
pic.setAttribute('width', len.toString() ); | |
pic.setAttribute('height', len.toString() ); | |
picdiv.appendChild(pic); | |
picdiv.appendChild(picLabel); | |
d.appendChild(picdiv); | |
nodeDiv.appendChild(d); | |
h = document.createElement('div'); | |
h.setAttribute('class','hbar'); | |
nodeDiv.appendChild(h); | |
var childrenDiv = document.createElement('div'); | |
childrenDiv.setAttribute('class','children-div'); | |
nodeDiv.appendChild(childrenDiv); | |
var leftChildDiv = document.createElement('div'); | |
leftChildDiv.setAttribute('class','child-div-left'); | |
childrenDiv.appendChild(leftChildDiv); | |
var vbar = document.createElement('div'); | |
vbar.setAttribute('class','vbar'); | |
childrenDiv.appendChild(vbar); | |
var rightChildDiv = document.createElement('div'); | |
rightChildDiv.setAttribute('class','child-div-right'); | |
childrenDiv.appendChild(rightChildDiv); | |
drawTree( tree.left, leftChildDiv, 50 ); | |
drawTree( tree.right, rightChildDiv, 50 ); | |
} | |
} | |
</script> | |
</head> | |
<body onload='fetchAndDraw()'> | |
<input type="text" id="lbox"></input> | |
<button id="test2" onclick="lclick()"/>Lookup</button> | |
<div id="lresponse"></div> | |
<hr/> | |
<input type="text" id="dbox"></input> | |
<button id="test3" onclick="dclick();"/>Delete</button> | |
<hr/> | |
<input type="text" id="ibox"></input> | |
<input type="text" id="iurl"></input> | |
<button id="test4" onclick="iclick()"/>Insert</button> | |
<hr/> | |
<button id="test5" onclick="getUndo(); fetchAndDraw()"/>Undo</button> | |
<div id="drawing-area"></div> | |
</body> | |
</html> |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment