Permalink
Browse files

Switch incoming.julius to Fay

  • Loading branch information...
1 parent 3e20ba9 commit f7527feab714a90a0b9a28c5eef81e5e43361d8b @snoyberg committed Oct 28, 2012
View
@@ -4,3 +4,5 @@ dist/
config/client_session_key.aes
photosorter.sqlite3
photosorter.keter
+*.o
+*.hi
View
@@ -30,6 +30,7 @@ import Handler.SetName
import Handler.SetDescription
import Handler.ToPostList
import Handler.UnPost
+import Handler.Command
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
View
@@ -0,0 +1,45 @@
+module Handler.Command where
+
+import Import
+import SharedTypes
+import Data.Aeson (decode)
+import Language.Fay.Convert
+import qualified Data.ByteString.Lazy as L
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text as T
+
+type HandleCommand = forall s. (forall a. Show a => Returns a -> a -> Handler s) -> Command -> Handler s
+
+handle :: HandleCommand -> Handler RepJson
+handle f = do
+ mtxt <- lookupPostParam "json"
+ case mtxt of
+ Nothing -> error "No JSON provided"
+ Just txt ->
+ case decode (L.fromChunks [encodeUtf8 txt]) >>= readFromFay of
+ Nothing -> error $ "Unable to parse input: " ++ show txt
+ Just cmd -> f go cmd
+ where
+ go Returns = jsonToRepJson . showToFay
+
+handleCommand :: HandleCommand
+handleCommand respond command =
+ case command of
+ AddPost date slug r -> do
+ liftIO $ addPost $ PostName $ T.pack $ filter (/= '-') date ++ slug
+ respond r ()
+ SetPost f' p' r -> do
+ let f = FilePath' $ T.pack f'
+ p = PostName $ T.pack p'
+ runDB $ do
+ x <- getBy $ UniqueMedia f
+ case x of
+ Nothing -> do
+ _ <- insert $ Media f (Just p)
+ return ()
+ Just (Entity key val) -> do
+ replace key $ val { mediaPost = Just p }
+ respond r ()
+
+postCommandR :: Handler RepJson
+postCommandR = handle handleCommand
View
@@ -17,6 +17,7 @@ getIncomingR root = do
defaultLayout $ do
setTitle "Incoming"
$(widgetFile "incoming")
+ $(fayFile "Incoming")
addScriptEither $ urlJqueryJs y
where
isChosen Nothing _ = False
View
@@ -21,6 +21,7 @@ import Control.Monad (foldM, filterM)
import Data.List (sortBy, sort)
import Data.Ord (comparing)
import Control.Arrow ((&&&))
+import Import.Fay as Import
#if __GLASGOW_HASKELL__ >= 704
import Data.Monoid as Import
View
@@ -0,0 +1,49 @@
+module Import.Fay
+ ( fayFile
+ ) where
+
+import Prelude
+import Yesod
+import Language.Haskell.TH.Syntax
+import Language.Fay.Compiler
+import Language.Fay.Types
+import Data.Default (def)
+import Text.Julius
+import qualified Data.Text as T
+import Data.Text.Lazy.Builder (fromText)
+import Settings.Development (development)
+import System.Process (rawSystem)
+import System.Exit (ExitCode (ExitSuccess))
+import Control.Monad (unless)
+
+fayFile :: String -> Q Exp
+fayFile
+ | development = fayFileReload
+ | otherwise = fayFileProd
+
+fayFileProd :: String -> Q Exp
+fayFileProd name = do
+ qAddDependentFile fp
+ ec <- qRunIO $ rawSystem "ghc" ["-O0", "--make", "-ifay", "-ifay-shared", fp]
+ unless (ec == ExitSuccess) $ error $ "Type checking of fay module failed: " ++ name
+ eres <- qRunIO $ compileFile config fp
+ case eres of
+ Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e
+ Right s -> [|toWidget $ const $ Javascript $ fromText $ T.pack s|]
+ where
+ fp = mkfp name
+
+mkfp :: String -> FilePath
+mkfp name = "fay/" ++ name ++ ".hs"
+
+config :: CompileConfig
+config = def
+ { configDirectoryIncludes = ["fay", "fay-shared"]
+ }
+
+fayFileReload :: String -> Q Exp
+fayFileReload name = [|
+ liftIO (compileFile config $ mkfp name) >>= \eres ->
+ (case eres of
+ Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e
+ Right s -> toWidget $ const $ Javascript $ fromText $ T.pack s)|]
View
@@ -16,3 +16,4 @@
/set-description SetDescriptionR POST
/topost ToPostListR GET
/topost/#PostName/unpost UnPostR POST
+/json CommandR POST
@@ -0,0 +1,15 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module SharedTypes where
+
+import Language.Fay.Prelude
+import Language.Fay.FFI
+
+data Returns a = Returns
+ deriving (Show, Read, Data, Typeable)
+
+data Command = AddPost String String (Returns ())
+ | SetPost String String (Returns ())
+ deriving (Show, Read, Data, Typeable)
+
+instance Foreign Command
View
@@ -0,0 +1,22 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Client.API where
+
+import SharedTypes
+
+import Language.Fay.FFI
+import Language.Fay.Prelude
+
+-- | Call a command.
+call :: (Foreign a) => (Returns a -> Command) -> (a -> Fay ()) -> Fay ()
+call f g = ajaxCommand (f Returns) g
+
+-- | Run the AJAX command.
+ajaxCommand :: (Foreign a) => Command -> (a -> Fay ()) -> Fay ()
+ajaxCommand = ffi "jQuery['ajax']({\
+ \ \"url\": '/json', \
+ \ \"type\": 'POST', \
+ \ \"data\": { \"json\": JSON.stringify(%1) }, \
+ \ \"dataType\": 'json', \
+ \ \"success\" : %2 \
+ \})"
View
@@ -0,0 +1,33 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Incoming where
+
+import Language.Fay.Prelude
+import Language.Fay.JQuery
+import Language.Fay.DOM
+import Language.Fay.FFI
+
+import Client.API
+import SharedTypes
+
+main :: Fay ()
+main = ready $ do
+ select "button.add-new-post" >>= onClick (\e -> do
+ alert' "You clicked the button"
+ eventSource e >>= hide >>= next >>= unhide
+ return False
+ )
+ select "button.add-new-post2" >>= onClick (\e -> do
+ t <- eventSource e
+ date <- parent t >>= childrenMatching "input[type=date]" >>= getVal
+ slug <- parent t >>= childrenMatching "input[type=text]" >>= getVal
+ call (AddPost date slug) $ const reload
+ return False
+ )
+ select "input[type=radio]" >>= onClick (\e -> do
+ t <- eventSource e
+ file <- parentsSelector "form" t >>= childrenMatching "input[name=file]" >>= getVal
+ post <- getVal t
+ call (SetPost file post) $ const $ return ()
+ return False
+ )
+ return ()
@@ -0,0 +1,36 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Language.Fay.DOM where
+
+import Language.Fay.FFI
+import Language.Fay.Prelude
+
+data Element
+instance Foreign Element
+
+-- | Get body.
+getBody :: Fay Element
+getBody = ffi "document['body']"
+
+data Timer
+instance Foreign Timer
+
+-- | Set a timer.
+setTimeout :: Double -> Fay () -> Fay Timer
+setTimeout = ffi "window['setTimeout'](%2,%1)"
+
+-- | Set a timer.
+setInterval :: Double -> Fay () -> Fay Timer
+setInterval = ffi "window['setInterval'](%2,%1)"
+
+-- | Clear a timer.
+clearTimeout :: Timer -> Fay ()
+clearTimeout = ffi "window['clearTimeout'](%1)"
+
+alert :: String -> Fay ()
+alert = ffi "window.alert(%1)"
+
+reload :: Fay ()
+reload = ffi "window.location.reload()"
Oops, something went wrong. Retry.

0 comments on commit f7527fe

Please sign in to comment.