greet.hs

{-# 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

index.html

<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>