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
let looong2 = | |
Eliom_predefmod.Xhtml.register_new_service | |
~path:["looong2"] | |
~get_params:unit | |
(fun sp () () -> | |
Lwt_preemptive.detach (fun () -> ()) () >>= fun () -> | |
return | |
(html | |
(head (title (pcdata "")) []) | |
(body [h1 [pcdata |
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
fmap (\x -> "xmlforest(" ++ concat (intersperse "," x) ++ ")") (fmap ((map (\(x,_) -> x))) ((describeTable c "vcurrency"))) |
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
insertEntity :: Context -> String -> ServerPartT IO Response | |
insertEntity serv w = | |
methodM GET >> do withData (\d -> handle serv w d) | |
where handle ctx t (TestGet p) = do | |
x <- liftIO (doInsertIntoTable ctx t p) | |
--- написав это сам, Дик Бёрд (ну или Бивис) впервые поверил, что он сможет освоить хаскель | |
res <- case x of | |
Nack(x) -> do fail x; return "<error/>" -- и особенно вот это | |
Ack _ -> return "<ok/>" | |
ok $ contentTypeXml $ toResponse res |
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
module ConnPool ( newConnPool, withConn, delConnPool ) where | |
import Control.Concurrent | |
import Control.Exception | |
import Control.Monad (replicateM) | |
import Database.HDBC | |
data Pool a = | |
Pool { poolMin :: Int, poolMax :: Int, poolUsed :: Int, poolFree :: [a] } |
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
WITH | |
schedule1 AS ( | |
SELECT | |
q2.object_id, | |
q2.trip_id, | |
q2.rule_id, | |
rule_type, | |
rule_name, | |
greatest(q2.tff, q2.tf) as tff, |
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
-- create or replace view vschedule4 as | |
create view vwtf1 as | |
WITH sched1 as ( | |
SELECT q.date AS trip_date, s.gos_number, bt.name AS bus_model, sh.name AS school_name, f_name_fmt(p.*) AS driver_name, t.name AS trip_name, g.name AS group_name, first_value(q.name) OVER w AS first_point, timezone('UTC'::text, first_value(q.start_time) OVER w)::timestamp without time zone AS first_point_plan, timezone('UTC'::text, first_value(q.time_actual) OVER w)::timestamp without time zone AS first_point_actual, last_value(q.name) OVER w1 AS last_point, timezone('UTC'::text, last_value(q.start_time) OVER w1)::timestamp without time zone AS last_point_plan, timezone('UTC'::text, last_value(q.time_actual) OVER w1)::timestamp without time zone AS last_point_actual, sum(q.fuckup_num) OVER w1 AS fuckup_num_sum, | |
CASE | |
WHEN sum(q.fuckup_num) OVER w1 > 0 THEN 'да'::text | |
ELSE 'нет'::text |
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
module AppState where | |
import Happstack.Server.SimpleHTTP (ServerPartT) | |
import Control.Concurrent.MVar | |
import Control.Monad.Reader | |
import qualified Data.Map as M | |
import qualified Data.Set as S | |
import Db (Context) | |
type MyServerPartT = ServerPartT (ReaderT AppState IO) |
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
main :: IO () | |
main = do | |
putStrLn "Init sessions..." | |
ctx <- newDbContext viewKeys | |
sd <- loadSessionData ctx | |
st <- initState ctx $ sessionsFromList sd | |
let reloadSessions = do | |
putStrLn "Reload sessions" | |
-- ctx' <- newDbContext viewKeys |
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
updateSessionsToState :: AppState -> Sessions -> IO () | |
updateSessionsToState s ns = do | |
liftIO $ putMVar (sessions s) ns |
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
test :: MyServerPartT Response | |
test = methodM [POST, GET] >> do | |
decodeBody reqPolicy | |
auth (Check ["test", "*"]) | |
ok $ toResponse "Okay" |