extra/long-urls/long-urls.factor

   1 ! Copyright (C) 2015 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors http http.client http.client.private kernel
   5 math namespaces ;
   6
   7 IN: long-urls
   8
   9 SYMBOL: max-redirects
  10 5 max-redirects set-global
  11
  12 <PRIVATE
  13
  14 SYMBOL: redirects
  15
  16 : http-head-no-redirects ( url -- response data )
  17     <head-request> 0 >>redirects http-request* ;
  18
  19 : next-url ( url -- next-url redirected? )
  20     redirects inc
  21     redirects get max-redirects get <= [
  22         dup http-head-no-redirects drop
  23         dup redirect? [
  24             nip "location" header t
  25         ] [ drop f ] if
  26     ] [ too-many-redirects ] if ;
  27
  28 PRIVATE>
  29
  30 : long-url ( short-url -- long-url )
  31     [ [ next-url ] loop ] with-scope ;