Permalink
Browse files

First checkin

  • Loading branch information...
0 parents commit c43c6fbcdf771df6fa9a09ea70e82383c9f06678 @gregorycollins committed Mar 23, 2009
@@ -0,0 +1,3 @@
+dist/**
+dist
+*~
No changes.
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
@@ -0,0 +1,33 @@
+Name: homepage
+Version: 0.1
+Synopsis: gregorycollins.net
+
+License: BSD3
+License-file: LICENSE
+Author: Gregory Collins
+
+Stability: Experimental
+Category: Web
+Build-type: Simple
+
+Extra-Source-Files:
+ src/*hs
+ static/*
+ templates/*.st
+
+Cabal-Version: >= 1.6
+
+Executable gregorycollins.net
+ Main-is: Main.hs
+ hs-source-dirs:
+ src
+ ghc-options: -Wall -funbox-strict-fields -O2 -fvia-C -optc-O3 -funfolding-use-threshold=16
+ Build-Depends: base >= 4 && <5, syb, HStringTemplate,
+ HStringTemplateHelpers, mtl, bytestring,
+ happstack-server >= 0.3,
+ containers, pretty, pureMD5,
+ directory, filepath, hscolour, HTTP, safe,
+ old-time, parsec, happstack-helpers,
+ DebugTraceHelpers, delicious, unix,
+ time, old-locale
+
@@ -0,0 +1,9 @@
+module Homepage
+(
+ module Homepage.Handlers
+, module Homepage.Types
+)
+where
+
+import Homepage.Handlers
+import Homepage.Types
@@ -0,0 +1,80 @@
+{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings, FlexibleContexts #-}
+
+-- | This module contains the top-level handler for the website.
+
+module Homepage.Handlers (topLevelHandler) where
+
+import Control.Monad.State.Strict
+
+import Data.Monoid
+import qualified Data.ByteString.Lazy.Char8 as B
+
+import Happstack.Helpers
+import Happstack.Server
+--import Happstack.Server.Parts
+
+import Homepage.Types
+import Homepage.Util.Templates
+import Homepage.Util.Delicious as Delicious
+
+import Text.StringTemplate
+
+
+topLevelHandler :: HomepageHandler
+topLevelHandler =
+-- gzip currently doesn't work. augh
+--
+-- do
+-- compressedResponseFilter
+ frontpage `mappend`
+ aboutpage `mappend`
+ (liftH staticfiles) `mappend`
+ temporaryPosts `mappend`
+ fourohfour
+
+
+frontpage :: HomepageHandler
+frontpage =
+ exactdir "/" $ do
+ bookmarks <- lift Delicious.getRecent
+ serveTemplate' "." "home" (setAttribute "recentBookmarks" bookmarks .
+ setAttribute "whichCss" ("home" :: String))
+
+aboutpage :: HomepageHandler
+aboutpage =
+ exactdir "/about" $ do
+ serveTemplate' "." "about" (setAttribute "whichCss"
+ ("posts" :: String))
+
+
+temporaryPosts :: HomepageHandler
+temporaryPosts = do
+ postContent <- lift $ (getTemplate "." "temppost1") >>=
+ (return . B.unpack . render)
+
+ let attrs :: [(String,String)]
+ attrs = [ ("websiteTitleExtra",
+ ": Building a website with Haskell, part 1")
+ , ("whichCss", "posts")
+ , ("postContent", postContent)
+ , ("postTitle", "Building a website with Haskell, part 1")
+ , ("postSummary", "Using the <a href=\"\
+ \http://www.happstack.com/\">happstack</a> \
+ \web framework to power a simple personal \
+ \website.")
+ , ("postDate", "march 26, 2009") ]
+
+ exactdir "/posts/2009/03/26/building-a-website-part-1" $
+ serveTemplate' "." "post" (setManyAttrib attrs)
+
+
+fourohfour :: HomepageHandler
+fourohfour = serveTemplate "." "404"
+
+
+-- N.B. "fileServeStrict" here is like normal "fileServe" from
+-- happstack 0.2.1, except modified to consume the file strictly
+-- (avoiding handle leaks)
+staticfiles :: WebHandler
+staticfiles = staticserve "static"
+ where staticserve d = dir d (fileServeStrict [] d)
@@ -0,0 +1,98 @@
+{-# LANGUAGE OverloadedStrings, UnboxedTuples, BangPatterns #-}
+
+-- | This module contains types (and a couple of functions) pertaining
+-- | to the website's global state, plus some synonyms
+module Homepage.Types where
+
+import Control.Concurrent.MVar
+import Control.Monad.State.Strict
+import qualified Network.Delicious as D
+import qualified Data.ByteString.Lazy.Char8 as B
+
+import Data.Time
+
+import Happstack.Server
+
+import Text.StringTemplate
+import Text.StringTemplate.Helpers
+
+
+------------------------------------------------------------------------
+-- * Type synonyms
+
+-- | type synonyms for templates & template groups
+type TemplateDirs = STDirGroups B.ByteString
+type TemplateGroup = STGroup B.ByteString
+type Template = StringTemplate B.ByteString
+
+
+------------------------------------------------------------------------
+-- * Homepage State
+
+-- | In order to not spam delicious, we only pull my recent feeds once
+-- | every four hours. So we need to keep the last posts and update
+-- | time.
+data DeliciousState = DeliciousState ![D.Post] !UTCTime
+
+
+-- | We're going to keep the templates inside the homepage state. The
+-- | variable is wrapped in an MVar because I'm planning on using
+-- | inotify to handle template reloads
+data HomepageState = HomepageState {
+ homepageDeliciousMVar :: MVar DeliciousState
+ , homepageTemplateMVar :: MVar TemplateDirs
+}
+
+
+-- | Create a homepage state object with new empty mvars
+emptyHomepageState :: IO HomepageState
+emptyHomepageState = do
+ d <- newEmptyMVar
+ t <- newEmptyMVar
+ return $! HomepageState d t
+
+
+-- | We'll put the homepage state into a state monad so we don't have
+-- | to pass it around everywhere
+type HomepageMonad = StateT HomepageState IO
+
+-- | Homepage handlers will have the following type
+type HomepageHandler = ServerPartT HomepageMonad Response
+
+-- | "standard" web handlers (like 'staticfiles') will have this type
+type WebHandler = ServerPartT IO Response
+
+-- | ..so we'll need a function to lift a "WebHandler" into the
+-- | "HomepageHandler"
+liftH :: ServerPartT IO a -> ServerPartT HomepageMonad a
+liftH = mapServerPartT liftIO
+
+
+-- | this IO action initializes the homepage's state and returns a
+-- | monad evaluator function
+-- | runner :: HomepageMonad a -> IO a
+-- | we'll pass this into simpleHTTP'.
+initHomepage :: IO (HomepageMonad a -> IO a)
+initHomepage = do
+ s <- emptyHomepageState
+
+ directoryGroups "templates" >>=
+ putMVar (homepageTemplateMVar s)
+
+ return $! runHomepage s
+
+
+
+runHomepage :: HomepageState -> HomepageMonad a -> IO a
+runHomepage hps = flip evalStateT hps
+
+
+------------------------------------------------------------------------
+-- * odds and ends
+
+-- | this instance should be in happstack already, it allows us to
+-- | treat a bytestring as an HTML response
+newtype BStoHTML = BStoHTML B.ByteString
+instance ToMessage BStoHTML where
+ toContentType _ = "text/html"
+ toMessage (BStoHTML a) = a
@@ -0,0 +1,150 @@
+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
+
+module Homepage.Util.Delicious
+(
+ getRecent
+, DiffPost(..)
+) where
+
+import qualified Control.Exception as Ex
+import Control.Concurrent.MVar
+import Control.Monad.State.Strict
+
+import Data.Char (isSpace)
+import Data.Maybe
+import Data.Time
+
+import System.Locale
+
+import Text.StringTemplate()
+import Text.StringTemplate.Classes
+
+import qualified Data.Map as Map
+import qualified Network.Delicious.JSON as D
+import qualified Network.Delicious.Types as D
+
+import Homepage.Types
+
+myDeliciousUserName :: String
+myDeliciousUserName = "how.gauche"
+
+type Age = String
+
+-- | a DiffPost is a delicious post plus an age string, e.g. '2 hours
+-- | ago'; we need to interpret the post in the context of the current
+-- | time in order to compute the age
+data DiffPost = DiffPost !D.Post !Age
+
+
+agePost :: TimeZone -> UTCTime -> D.Post -> DiffPost
+agePost tz now post = DiffPost post s
+ where
+ dt = parseDeliciousTime $ D.postStamp post
+ s = humanReadableTimeDiff tz now dt
+
+
+getRecentPosts :: MVar DeliciousState -> IO [D.Post]
+getRecentPosts mvar = do
+ now <- getCurrentTime
+ empty <- isEmptyMVar mvar
+ if empty then do
+ posts <- getRecentPosts'
+ tryPutMVar mvar $! DeliciousState posts now
+ return posts
+ else do
+ modifyMVar mvar $! \oldstate@(DeliciousState oldposts oldtime) -> do
+ if tooOld now oldtime then do
+ posts <- getRecentPosts'
+ let newstate = DeliciousState (posts `seq` posts) now
+ return $! (newstate `seq` newstate, posts `seq` posts)
+ else
+ return $! (oldstate, oldposts)
+ where
+ tooOld :: UTCTime -> UTCTime -> Bool
+ tooOld now old = diffUTCTime now old > 60 * 60 * 4
+
+
+getRecentPosts' :: IO [D.Post]
+getRecentPosts' = do
+ posts <- Ex.handle (\(_::Ex.SomeException) -> return [])
+ (D.runDelic D.nullUser
+ "http://feeds.delicious.com/v2/json" $
+ D.getUserBookmarks myDeliciousUserName)
+ return $ take 5 posts
+
+
+instance ToSElem DiffPost where
+ toSElem (DiffPost (D.Post href _ desc notes tags _ _) age) =
+ SM $! Map.fromList [ ("date", toSElem age)
+ , ("title", toSElem desc)
+ , ("summary", toSElem notes)
+ , ("href", toSElem href)
+ , ("tags", toSElem tags) ]
+
+
+
+parseDeliciousTime :: String -> UTCTime
+parseDeliciousTime = fromJust . parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"
+
+
+humanReadableTimeDiff :: TimeZone -- ^ our timezone
+ -> UTCTime -- ^ current time
+ -> UTCTime -- ^ old time
+ -> String
+humanReadableTimeDiff tz curTime oldTime =
+ helper diff
+ where
+ diff = diffUTCTime curTime oldTime
+
+ minutes :: NominalDiffTime -> Double
+ minutes n = realToFrac $ n / 60
+
+ hours :: NominalDiffTime -> Double
+ hours n = (minutes n) / 60
+
+ days :: NominalDiffTime -> Double
+ days n = (hours n) / 24
+
+ weeks :: NominalDiffTime -> Double
+ weeks n = (days n) / 7
+
+ years :: NominalDiffTime -> Double
+ years n = (days n) / 365
+
+ i2s :: RealFrac a => a -> String
+ i2s !n = show m
+ where
+ m :: Int
+ m = truncate n
+
+ old = utcToLocalTime tz oldTime
+
+ trim = f . f
+ where f = reverse . dropWhile isSpace
+
+ dow = trim $! formatTime defaultTimeLocale "%l:%M %p on %A" old
+ thisYear = trim $! formatTime defaultTimeLocale "%b %e" old
+ previousYears = trim $! formatTime defaultTimeLocale "%b %e, %Y" old
+
+ helper !d | d < 1 = "one second ago"
+ | d < 60 = i2s d ++ " seconds ago"
+ | minutes d < 2 = "one minute ago"
+ | minutes d < 60 = i2s (minutes d) ++ " minutes ago"
+ | hours d < 2 = "one hour ago"
+ | hours d < 24 = i2s (hours d) ++ " hours ago"
+ | days d < 5 = dow
+ | days d < 10 = i2s (days d) ++ " days ago"
+ | weeks d < 2 = i2s (weeks d) ++ " week ago"
+ | weeks d < 5 = i2s (weeks d) ++ " weeks ago"
+ | years d < 1 = thisYear
+ | otherwise = previousYears
+
+
+getRecent :: HomepageMonad [DiffPost]
+getRecent = do
+ delMVar <- get >>= return . homepageDeliciousMVar
+ now <- liftIO $ getCurrentTime
+ tz <- liftIO $ getCurrentTimeZone
+
+ liftIO $ getRecentPosts delMVar >>=
+ return . map (agePost tz now)
Oops, something went wrong.

0 comments on commit c43c6fb

Please sign in to comment.