Skip to content

Commit

Permalink
Add custom blog urls
Browse files Browse the repository at this point in the history
  • Loading branch information
rvl committed Oct 25, 2017
1 parent 6ac9173 commit be0b969
Showing 4 changed files with 13 additions and 9 deletions.
16 changes: 10 additions & 6 deletions common/Fetch.hs
Original file line number Diff line number Diff line change
@@ -38,6 +38,7 @@ import Data.ByteString (ByteString)
import Data.Time.Calendar (Day)
import Control.Concurrent.Async
import Control.Exception
import Network.URI (relativeTo)

import Data.GADT.Compare.TH
import qualified Data.Dependent.Map as DM
@@ -144,13 +145,16 @@ jsonReq' cfg name = Request { reqMethod = GET
}

getBlogHtml :: Config -> TourDay -> IO (Maybe MisoString)
getBlogHtml cfg TourDay{..} = (>>= munge) <$> getBlogHtml' postUrl
getBlogHtml cfg TourDay{..} = (>>= munge) <$> getBlogHtml' (JS.pack . show $ postUrl)
where
munge = fmap (fixImageUrls postUrl) . htmlBody
dayBlog = Nothing -- fixme: add field to TourDay
defaultPage = toMisoString (show dayDate <> "-tour-" <> show dayNum)
munge = fmap (fixImageUrls . JS.pack . show $ postUrl) . htmlBody
defaultPage = URI "" Nothing (show dayDate <> "-tour-" <> show dayNum) "" ""
page = fromMaybe defaultPage dayBlog
postUrl = (JS.pack . show $ cfgBlogUrl cfg) <> page <> "/"
postUrl = addTrailingSlash page `relativeTo` cfgBlogUrl cfg
addTrailingSlash (URI s a p q f) = URI s a p' q f
where p' | null p = ""
| last p == '/' = p
| otherwise = p <> "/"

getBlogHtml' :: MisoString -> IO (Maybe MisoString)
getBlogHtml' postUrl = catch (contents <$> xhr req) handle
@@ -175,7 +179,7 @@ htmlBody = fmap getBody . matchBody . oneLine
flags = RE.REFlags True True -- multiline, ignore case
getBody = head . RE.subMatched

foreign import javascript unsafe "$2.replace(new RegExp('<img src=\"([^\"]+)\"', 'g'), '<img src=\"' + $1 + '$1\"')"
foreign import javascript unsafe "$2.replace(new RegExp('<img src=\"([^\"]+)\"', 'g'), function(m, p1) { var src = p1.match(new RegExp('^(https?:|/)')) ? p1 : $1 + p1; return '<img src=\"' + src + '\"'; })"
fixImageUrls :: MisoString -> MisoString -> MisoString

#else
4 changes: 2 additions & 2 deletions common/TourJson.hs
Original file line number Diff line number Diff line change
@@ -26,7 +26,7 @@ import qualified Data.Map as M
import qualified Data.Vector as V
import Naqsha.Geometry
import Data.Scientific (toRealFloat)
import Network.URI (URI(..), parseURI)
import Network.URI (URI(..), parseURIReference)

import Types

@@ -107,7 +107,7 @@ instance ToJSON URI where
toJSON = String . T.pack . show

instance FromJSON URI where
parseJSON (String u) = case parseURI (T.unpack u) of
parseJSON (String u) = case parseURIReference (T.unpack u) of
Just uri -> pure uri
Nothing -> fail "Not a valid URI"

Binary file modified data/tour2008.yaml
Binary file not shown.
2 changes: 1 addition & 1 deletion frontend/tour.sass
Original file line number Diff line number Diff line change
@@ -233,7 +233,7 @@ section.blog
color: #666
margin-bottom: 1em

.figure
.figure, .g2image_centered, .g2image_float_left, .g2image_float_right
background: black
color: #ddd
padding: 4px

0 comments on commit be0b969

Please sign in to comment.